Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
107 lines (88 sloc) 3.1 KB
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
import Data.Unfoldable
import Data.Unfolder
import Data.Maybe
import System.Random
import Data.List (intercalate)
-- Red-Black tree implementation adapted from https://gist.github.com/2660297
data Nat = Zero | Succ Nat
data NatW :: Nat -> * where
ZeroW :: NatW 'Zero
SuccW :: NatW n -> NatW ('Succ n)
data RedBlack = Black | Red
data RedBlackTree a where
T :: Node 'Black n a -> RedBlackTree a
deriving instance Show a => Show (RedBlackTree a)
data Node :: RedBlack -> Nat -> * -> * where
Leaf :: Node 'Black 'Zero a
B :: Node cL n a -> a -> Node cR n a -> Node 'Black ('Succ n) a
R :: Node 'Black n a -> a -> Node 'Black n a -> Node 'Red n a
deriving instance Show a => Show (Node c n a)
instance Unfoldable RedBlackTree where
unfold = u ZeroW
where
u :: forall n f a. (Unfoldable (Node 'Black n), Unfolder f)
=> NatW n -> f a -> f (RedBlackTree a)
u n fa = choose
[ T <$> (unfold :: f a -> f (Node 'Black n a)) fa
, u (SuccW n) fa
]
instance Unfoldable (Node 'Black 'Zero) where
unfold _ = choose [ pure Leaf ]
instance Unfoldable (Node 'Black n) => Unfoldable (Node 'Black ('Succ n)) where
unfold = u
where
u :: forall f a. Unfolder f => f a -> f (Node 'Black ('Succ n) a)
u fa = choose
[ B <$> b <*> fa <*> b
, B <$> b <*> fa <*> r
, B <$> r <*> fa <*> b
, B <$> r <*> fa <*> r
]
where
r :: f (Node 'Red n a)
r = unfold fa
b :: f (Node 'Black n a)
b = unfold fa
instance Unfoldable (Node 'Black n) => Unfoldable (Node 'Red n) where
unfold fa = choose [ R <$> unfold fa <*> fa <*> unfold fa ]
rbtree :: Int -> RedBlackTree Int
rbtree l = fromJust $ fromList [0..l]
rbtreeShapes :: Int -> [RedBlackTree ()]
rbtreeShapes d = limitDepth d unfold_
randomRBTree :: IO (RedBlackTree Bool)
randomRBTree = getStdRandom randomDefault
newtype Formula = Formula [Integer]
instance Show Formula where
show (Formula xs)
| all (== 0) xs = "0"
| otherwise = intercalate " + " $ map showOne $ filter ((/=0) . fst) $ zip xs [(0::Int)..]
where
showOne (x, 0) = show x
showOne (1, 1) = "x"
showOne (x, 1) = show x ++ "x"
showOne (1, n) = "x^" ++ show n
showOne (x, n) = show x ++ "x^" ++ show n
add, mul :: [Integer] -> [Integer] -> [Integer]
add xs [] = xs
add [] ys = ys
add (x:xs) (y:ys) = (x + y) : add xs ys
mul _ [] = []
mul [] _ = []
mul (x:xs) (y:ys) = (x * y) : add (map (x*) ys) (add (map (y*) xs) (0 : mul xs ys))
instance Num Formula where
fromInteger x = Formula [x]
Formula xs + Formula ys = Formula (add xs ys)
Formula xs * Formula ys = Formula (mul xs ys)
varX :: Formula
varX = Formula [0, 1]
-- See http://oeis.org/A001137
rbFormula :: Int -> NumConst Formula (RedBlackTree a)
rbFormula d = ala (limitDepth d) unfold (NumConst varX)