Permalink
Browse files

check in some old tests [ci skip]

  • Loading branch information...
1 parent 4a36256 commit f75d74f008140cfdb3a05c11a76c4fd08c770473 Brent Yorgey committed Aug 9, 2013
Showing with 136 additions and 0 deletions.
  1. +67 −0 test/BTreeTest.hs
  2. +69 −0 test/BTreeTestPure.hs
View
@@ -0,0 +1,67 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+
+import Control.Applicative
+import Control.Lens hiding (( # ))
+import Control.Monad.Random
+import Control.Monad.Reader
+import Control.Monad.State
+
+import Diagrams.Backend.Cairo.CmdLine
+import Diagrams.Prelude
+
+import Diagrams.TwoD.Layout.Tree
+
+t = BNode () (BNode () (leaf ()) (leaf ())) (BNode () Empty (BNode () (leaf ()) Empty))
+
+fact n = product [1..n]
+binom n k = fact n `div` (fact k * fact (n-k))
+
+-- sierpinskiTree n k
+-- |
+-- where b = binom n k
+
+drawT = maybe mempty (renderTree (const (circle 0.05 # fc black)) (~~))
+ . symmLayoutBin' with { slVSep = 0.5 }
+
+main = do
+ t <- genTree 1000 0.1
+ defaultMain (drawT t # centerXY # pad 1.1 # sized (Width 4))
+
+------------------------------------------------------------
+-- Critical Boltzmann generator for binary trees
+
+genTreeCrit :: ReaderT Int (StateT Int (RandT StdGen Maybe)) (BTree ())
+genTreeCrit = do
+ r <- getRandom
+ if r <= (1/2 :: Double)
+ then atom >> return Empty
+ else atom >> (BNode () <$> genTreeCrit <*> genTreeCrit)
+
+atom :: ReaderT Int (StateT Int (RandT StdGen Maybe)) ()
+atom = do
+ targetSize <- ask
+ curSize <- get
+ when (curSize >= targetSize) mzero
+ put (curSize + 1)
+
+genOneTree :: Int -> Double -> IO (Maybe (BTree ()))
+genOneTree size eps = do
+ g <- newStdGen
+ let sizeWiggle = floor $ fromIntegral size * eps
+ maxSz = size + sizeWiggle
+ minSz = size - sizeWiggle
+ let mt = (evalRandT ?? g) . (runStateT ?? 0) . (runReaderT ?? maxSz) $ genTreeCrit
+ case mt of
+ Nothing -> return Nothing
+ Just (t,sz) -> if sz >= minSz then return (Just t) else return Nothing
+
+genTree' :: Int -> Double -> StateT Int IO (BTree ())
+genTree' size eps = do
+ mt <- liftIO (genOneTree size eps)
+ modify (+1)
+ case mt of
+ Nothing -> genTree' size eps
+ Just t -> return t
+
+genTree :: Int -> Double -> IO (BTree ())
+genTree size eps = evalStateT (genTree' size eps) 0
View
@@ -0,0 +1,69 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+
+import Control.Applicative
+import Control.Lens hiding (( # ))
+import Control.Monad.Random
+import Control.Monad.Reader
+import Control.Monad.State
+
+import Diagrams.Backend.Cairo.CmdLine
+import Diagrams.Prelude
+
+import Diagrams.TwoD.Layout.Tree
+
+t = BNode () (BNode () (leaf ()) (leaf ())) (BNode () Empty (BNode () (leaf ()) Empty))
+
+fact n = product [1..n]
+binom n k = fact n `div` (fact k * fact (n-k))
+
+-- sierpinskiTree n k
+-- |
+-- where b = binom n k
+
+drawT = maybe mempty (renderTree (const (circle 0.05 # fc black)) (~~))
+ . symmLayoutBin' with { slVSep = 0.5 }
+
+main = do
+ let t = genTree 500 0.05
+ defaultMain (drawT t # centerXY # pad 1.1 # sized (Width 4))
+
+------------------------------------------------------------
+-- Critical Boltzmann generator for binary trees
+
+genTreeCrit :: ReaderT Int (StateT Int (RandT StdGen Maybe)) (BTree ())
+genTreeCrit = do
+ r <- getRandom
+ if r <= (1/2 :: Double)
+ then return Empty
+ else atom >> (BNode () <$> genTreeCrit <*> genTreeCrit)
+
+atom :: ReaderT Int (StateT Int (RandT StdGen Maybe)) ()
+atom = do
+ targetSize <- ask
+ curSize <- get
+ when (curSize >= targetSize) mzero
+ put (curSize + 1)
+
+genOneTree :: Int -> Int -> Double -> Maybe (BTree ())
+genOneTree seed size eps =
+ case mt of
+ Nothing -> Nothing
+ Just (t,sz) -> if sz >= minSz then Just t else Nothing
+
+ where
+ g = mkStdGen seed
+ sizeWiggle = floor $ fromIntegral size * eps
+ maxSz = size + sizeWiggle
+ minSz = size - sizeWiggle
+ mt = (evalRandT ?? g) . (runStateT ?? 0) . (runReaderT ?? maxSz) $ genTreeCrit
+
+genTree' :: Int -> Int -> Double -> State Int (BTree ())
+genTree' seed size eps = do
+ let mt = genOneTree seed size eps
+ modify (+1)
+ case mt of
+ Nothing -> genTree' (seed+1) size eps
+ Just t -> return t
+
+genTree :: Int -> Double -> BTree ()
+genTree size eps = evalState (genTree' 0 size eps) 0

0 comments on commit f75d74f

Please sign in to comment.