{-# LANGUAGE TemplateHaskell #-} module HW02 ( Rope ( Node, weight, left, right, Leaf, value ) , index , empty , size , valid , validWithRate , insert , delete , fromList , fromListWithRate , toList -- * Tests , Action (..) , ActionSeq (..) , replayRope , replayList , prop_compare_with_list , runTests ) where -- note: it is a good idea to write all imported functions explicitly for clarity and collision avoidance import Data.Default.Class ( Default, def ) -- package data-default-class import Test.QuickCheck ( Args ( maxSuccess ), quickCheckWithResult, stdArgs , Arbitrary ( arbitrary, shrink ), Gen, choose, frequency , forAllProperties, Property, (===), oneof ) import Data.Maybe ( catMaybes, fromMaybe, maybe ) import Data.List ( splitAt ) import Data.Bifunctor ( bimap ) -- | A rope structure, which stores a list of values of type @a@. -- You are not allowed to change this definition. data Rope a = Node { weight :: Int -- ^ node weight , left :: Maybe (Rope a) -- ^ left subtree , right :: Maybe (Rope a) -- ^ right subtree } | Leaf { weight :: Int -- ^ length of sublist , value :: [a] -- ^ sublist } deriving (Show, Read) -- | Creates an empty rope (stores an empty list). instance Default (Rope a) where def = Leaf 0 [] -- | Return the value at the position @i@. index :: Int -> Rope a -> Maybe a index i Leaf { weight = w, value = v } = if i < 0 || i >= w then Nothing else Just $ v !! i index i Node { weight = w, left = l, right = r } | i < 0 = Nothing | i < w = indexMaybe i l | otherwise = indexMaybe ( i - w ) r indexMaybe :: Int -> Maybe (Rope a) -> Maybe a indexMaybe _ Nothing = Nothing indexMaybe i ( Just rope ) = index i rope -- | Is the stored list empty? empty :: Rope a -> Bool empty Leaf { value = v } = null v empty Node { left = l, right = r } = maybe True empty l && maybe True empty r -- | Get the size (length of the stored list) of the given rope. size :: Rope a -> Int size Leaf { weight = w } = w size Node { weight = w, right = r } = w + sizeMaybe r sizeMaybe :: Maybe (Rope a) -> Int sizeMaybe ( Just r ) = size r sizeMaybe _ = 0 -- | Check if the given rope is valid: weights are calculated correctly and -- every 'Node' has at least one descendant. valid :: Rope a -> Bool valid = validWithRate maxBound -- | Check if the rope is valid and if the weight of each leaf node is at most the given -- value (rate). validWithRate :: Int -> Rope a -> Bool validWithRate rate rope = let ( isValid, _ ) = validWithRateWithSize rate rope in isValid validWithRateWithSize :: Int -> Rope a -> ( Bool, Int ) validWithRateWithSize rate Leaf { weight = w, value = v } = ( w == length v && w <= rate, w ) validWithRateWithSize rate Node { left = Just l, right = Nothing, weight = w } = let ( isValidL, sizeL ) = validWithRateWithSize rate l in ( isValidL && sizeL == w, w ) validWithRateWithSize rate Node { left = Just l, right = Just r, weight = w } = let ( isValidL, sizeL ) = validWithRateWithSize rate l in let ( isValidR, sizeR ) = validWithRateWithSize rate r in ( isValidL && isValidR && sizeL == w, sizeL + sizeR ) validWithRateWithSize rate Node { left = Nothing, right = Just r, weight = w } = let ( isValidR, sizeR ) = validWithRateWithSize rate r in ( w == 0 && isValidR, sizeR ) validWithRateWithSize _ _ = ( False, 0 ) -- Create constant to build rope with this leaf weight leafWeight :: Int leafWeight = 5 -- | Inserts a list into a rope at the given position. -- If the given position is invalid (out of range), then the given rope doesn't change. -- -- For example: @'insert' 3 [10, 11, 42] ('fromList' [0, 1, 2, 3, 4, 5])@ -- represents the same sequence as @'fromList' [0, 1, 2, 10, 11, 42, 3, 4, 5]@. insert :: Int -- ^ position -> [a] -- ^ given list to insert -> Rope a -- ^ given rope -> Rope a -- ^ result insert pos xs node@Node { weight = w, left = l, right = r } | pos < 0 = node | pos <= w = node { left = fmap (insert pos xs) l, weight = w + length xs } | otherwise = node { right = fmap (insert (pos - w) xs) r } insert pos xs leaf@Leaf { weight = w, value = v } | pos > w || pos < 0 = leaf | length xs + w >= leafWeight = let newV = newValue pos xs v in let halfLen = length newV `div` 2 in Node { weight = halfLen , left = Just ( Leaf { weight = halfLen, value = take halfLen newV } ) , right = Just ( Leaf { weight = length newV - halfLen, value = drop halfLen newV } ) } | otherwise = Leaf { weight = w + length xs, value = newValue pos xs v } where newValue p list old = let ( start, end ) = splitAt p old in start ++ list ++ end -- | Removes a sublist. -- If the given position is invalid (out of range), then the given rope doesn't change. -- If the position is valid, but the range ends after the end of the rope, -- removes all elements from the position to the end. delete :: Int -- ^ beginning position to remove -> Int -- ^ length of the substring to remove -> Rope a -- ^ given rope -> Rope a -- ^ result delete i c rope = fromMaybe def ( deleteM i c rope ) deleteM :: Int -> Int -> Rope a -> Maybe ( Rope a ) deleteM i c leaf@Leaf { weight = w, value = v } | i > w || i < 0 || c <= 0 = pure leaf | w == 0 = Nothing | otherwise = pure $ leaf { value = newValue, weight = length newValue } where newValue = take i v ++ drop ( i + c ) v deleteM i c node = case beforeMinimalize i c node of Node { left = Nothing, right = Nothing } -> Nothing Node { left = Nothing, right = r } -> r Node { left = l, right = Nothing } -> l rope -> pure rope where beforeMinimalize :: Int -> Int -> Rope a -> Rope a beforeMinimalize dIndex dCount ropeNode@Node { weight = w, left = l, right = r } | dIndex < 0 || dCount <= 0 = ropeNode | dIndex + dCount <= w = ropeNode { weight = w - c, left = l >>= deleteM dIndex dCount } | dIndex > w = ropeNode { right = r >>= deleteM (i - w) dCount } | otherwise = ropeNode { weight = dIndex, left = l >>= deleteM dIndex c, right = r >>= deleteM 0 ( dCount - w + dIndex ) } beforeMinimalize _ _ _ = undefined -- | Create a rope that stores the given list. fromList :: [a] -> Rope a fromList = fromListWithRate leafWeight -- | Create a rope that stores the given list and the weight of each leaf node is at -- most the given value (rate). The rope should be balanced. fromListWithRate :: Int -> [a] -> Rope a fromListWithRate rate xs = let listSize = length xs in if listSize <= rate then Leaf { weight = listSize, value = xs } else Node { left = Just ( fromListWithRate rate ( take ( listSize `div` 2 ) xs ) ) , right = Just ( fromListWithRate rate ( drop ( listSize `div` 2 ) xs ) ) , weight = listSize `div` 2 } -- | Get the list that is stored in the given rope. toList :: Rope a -> [a] toList Leaf { value = v } = v toList Node { left = Just l, right = Just r } = toList l ++ toList r toList Node { left = Just l, right = Nothing } = toList l toList Node { left = Nothing, right = Just r } = toList r toList _ = [ ] -- QuickCheck test ------------------------------------------------------------ -- Anything prefixed with @prop_@ will be picked and executed by 'runTests' -- some very basic tests prop_empty :: Bool prop_empty = empty ( def :: Rope Char ) prop_insert_delete_def :: String -> Bool prop_insert_delete_def s = empty . delete 0 ( length s ) $ insert 0 s def prop_def_size :: Property prop_def_size = size ( def :: Rope Int ) === 0 -- | Here we give you an instance of 'Arbitrary' for 'Rope' instance (Arbitrary a) => Arbitrary (Rope a) where -- | Generate an arbitrary *valid* 'Rope' (calculate weights correctly). arbitrary = arbitrary >>= createChild shrink Leaf { value = v } = map ( \list -> Leaf { weight = length list, value = list } ) $ shrink v shrink Node { left = l, right = r } = catMaybes [ l, r ] -- | Generate a node of 'Rope' based on the given list. createChild :: [a] -> Gen (Rope a) createChild [] = pure def createChild list = do indexSplit <- choose (0, length list) -- bimap applies the first function to the first element of the pair and the second to the second let (gl, gr) = bimap createChild createChild (splitAt indexSplit list) together = createChild list frequency [ (2, pure $ def { weight = length list, value = list }) , (1, fmap (\a -> Node { weight = length list, left = Just a, right = Nothing }) together) , (1, fmap (\a -> Node { weight = 0, left = Nothing, right = Just a }) together) , (5, gl >>= \l -> gr >>= \r -> pure Node { weight = indexSplit, left = Just l, right = Just r }) ] -- test that our generator generates valid ropes prop_arbitrary_valid :: Rope Char -> Bool prop_arbitrary_valid = valid -- | This data type describes actions over 'Rope' in such a way that these -- actions can be generated by @QuickCheck@. data Action a = Insert Int [a] | Delete Int Int deriving Show -- | Write an instance for generation of 'Rope' actions. Keep in mind that -- 'shrink' should try to do one change in each step and must never generate -- the same value as its argument (to prevent cycling). Arbitrary should be -- written in such a way that it generates slightly more inserts (in total) -- then erases. instance (Arbitrary a) => Arbitrary (Action a) where arbitrary = oneof [ Insert <$> arbitrary <*> arbitrary , Delete <$> arbitrary <*> arbitrary ] shrink (Insert i xs) = ( flip Insert xs <$> shrink i ) ++ ( Insert i <$> shrink xs ) shrink (Delete i c) = ( flip Delete c <$> shrink i ) ++ ( Delete i <$> shrink c ) -- | A sequence of actions for 'Arbitrary' instance. newtype ActionSeq a = ActionSeq { actions :: [Action a] } deriving Show -- | We give you a simple instance of 'Arbitrary' for 'ActionSeq' (which just -- uses the implementation for a list of 'Action's). instance (Arbitrary a) => Arbitrary (ActionSeq a) where arbitrary = ActionSeq <$> arbitrary shrink (ActionSeq as) = ActionSeq <$> shrink as -- | Produce a 'Rope' that corresponds to the given sequence of actions. replayRope :: ActionSeq a -> Rope a replayRope = foldl replay def . actions where replay rope ( Insert i xs ) = insert i xs rope replay rope ( Delete i c ) = delete i c rope -- | Produce a list that corresponds to the given sequence of actions. -- -- You are not allowed to use the functions that you implemented for the 'Rope' -- structure here, because you want to test your function against a trustworthy -- implementation. replayList :: ActionSeq a -> [a] replayList = foldl replay [ ] . actions where replay list ( Insert i xs ) | i < 0 || i > length list = list | otherwise = let ( start, end ) = splitAt i list in start ++ xs ++ end replay list ( Delete i c ) | i < 0 || i > length list || c <= 0 = list | otherwise = take i list ++ drop ( i + c ) list -- write your own tests here prop_delete_size :: Int -> String -> Rope Char -> Property prop_delete_size i xs rope = size ( delete i ( length xs ) ir ) === size rope where ir = insert i xs rope prop_insert_delete :: Int -> [Int] -> Rope Int -> Property prop_insert_delete i xs rope = toList ( delete i ( length xs ) ( insert i xs rope ) ) === toList rope prop_insert_invalid_index :: Rope Char -> Property prop_insert_invalid_index rope = toList rope === ( toList . insert ( -1 ) "42" ) rope prop_from_to_list :: Rope Char -> Property prop_from_to_list rope = toList rope === ( toList . fromList . toList ) rope -- | Write a property that produces a 'Rope' and a list from the given sequence -- and compares them if they hold exactly the same data. Try to write this in -- such a way that it has nice error messages. prop_compare_with_list :: ActionSeq Char -> Property prop_compare_with_list acts = replayList acts === ( toList . replayRope ) acts -- QuickCheck TemplateHaskell magic follows: -- this makes sure GHC can find all our test, see -- -- if you want return [] -- | Run all our @prop_*@ tests using QuickCheck, with 1000 tests for each property. -- -- The @$@ is a TemplateHaskell special symbol which means the following -- expression (@forAllProperties@ in our case) is evaluated at compile-time. runTests :: IO Bool runTests = $forAllProperties (quickCheckWithResult stdArgs { maxSuccess = 1000 })