diff options
Diffstat (limited to 'comp3141')
| -rw-r--r-- | comp3141/hare/Hare.hs | 406 | ||||
| -rw-r--r-- | comp3141/tortoise/Tortoise.hs | 177 |
2 files changed, 583 insertions, 0 deletions
diff --git a/comp3141/hare/Hare.hs b/comp3141/hare/Hare.hs new file mode 100644 index 0000000..8da7287 --- /dev/null +++ b/comp3141/hare/Hare.hs @@ -0,0 +1,406 @@ +module Hare where + +import Data.Traversable +import Data.Word +import Data.List +import Data.Maybe +import Control.Monad.State +import Test.QuickCheck +import GHC.Enum + +import RoverInterface +import RoverModel + +-- PART 1: FINDING WAYPOINTS + +data Path wp + = From wp + | GoTo (Path wp) wp + deriving (Eq) + +instance Show wp => Show (Path wp) where + show (From x) = "From " ++ show x + show (GoTo xs x) = show xs ++ " >:> " ++ show x + +-- Problem 1. Define a function `wf` that returns `True` +-- precisely if a given `Path` is well-formed according +-- to the rules set out in the specification. + +-- turn recrsive path into more managable list of waypoints +recurse_waypoints :: (Wp wp) => Path wp -> [wp] -> [wp] +recurse_waypoints (From wp) paths = paths ++ [wp] +recurse_waypoints (GoTo p wp) paths = paths ++ [wp] ++ (recurse_waypoints p paths) + +path_to_waypoints :: (Wp wp) => Path wp -> [wp] +path_to_waypoints p = recurse_waypoints p [] + +get_waypoint :: (Wp wp) => Path wp -> wp +get_waypoint (From wp) = wp +get_waypoint (GoTo p wp) = wp + +wf :: (Wp wp) => Path wp -> Bool +wf (From wp) = True -- a path From x is always well formed +wf (GoTo p wp) = + ((wp) `elem` (navigableFrom next)) && -- x is navigable from the endpoint of the path xs + (wf p) && -- the path xs is itself well formed + ((nub waypoints) == waypoints) where -- only unique waypoints + waypoints = (path_to_waypoints p) ++ [wp] + next = (get_waypoint p) + +-- Problem 2. Define a smart constructor `>:>` for `GoTo` +-- that returns `Nothing` if adding the given waypoint +-- to the given path would result in a non-well-formed path. +(>:>) :: (Wp wp) => Path wp -> wp -> Maybe (Path wp) +p >:> wp = if (wf new_path) then (Just new_path) else Nothing where + new_path = (GoTo p wp) + +-- Problem 3. Write a function `extendPath` which returns +-- all possible ways of extending the given `Path` by appending +-- a single additional waypoint. + +extendPath :: (Wp wp) => Path wp -> [Path wp] +extendPath p = catMaybes (map (\potential -> (p >:> potential)) potentials) where + potentials = navigableFrom (get_waypoint p) + +-- Problem 4. Implement a function `findPaths` which returns +-- all possible ways of extending the given `Path` (by appending +-- any number of additional waypoints) into a path that ends +-- at the given target waypoint. + +make_full_solution :: (Wp wp) => [Path wp] -> wp -> [Path wp] +make_full_solution paths target = + if ((length incomplete) <= 0) then solutions else solutions ++ (make_full_solution incomplete target) where + potential = concat (map (\p -> extendPath p) paths) + incomplete = filter (\p -> (head (path_to_waypoints p)) /= target) potential + solutions = filter (\p -> (head (path_to_waypoints p)) == target) potential + +findPaths :: (Wp wp) => Path wp -> wp -> [Path wp] +findPaths p target = if ((get_waypoint p) == target) then [p] else make_full_solution [p] target + +-- Efficiency mark 5: your solution should not spend time +-- expanding "useless" partial solutions. + + + + +--- PART 2: DISK MATTERS - ENCODE/DECODE + +-- The floppy disk drive has no means of tracking the +-- angular position of the spinning magnetic disk. +-- This means that in principle, reading/writing can +-- begin at any position within the track, and the +-- user has no control over where the reading/writing +-- starts from. + +-- For example, if you write [1,2,3,4,5,6] on a track of +-- capacity 6, it can happend that reading the track next +-- time will result in [5,6,1,2,3,4] or [2,3,4,5,6,1]. Note +-- however that the disk can spin only in one direction, so +-- you will never get a result like [6,5,4,3,2,1]. + +-- In this subproblem, you will come up with an encoding +-- scheme gets around the problem of the spinning disk. + +-- represents a list of bytes encoded using the scheme + +-- +data Encoded = Encoded [Word8] deriving (Show, Eq) + +unEncoded :: Encoded -> [Word8] +unEncoded (Encoded ws) = ws + +-- Problem 5. Implement a function `rotate` which simulates +-- the effect of the spinning disk by rotating the given +-- list to the left by the given number of entries. E.g. +-- rotate 3 (Encoded [1,2,3,4]) = Encoded [4,1,2,3] +-- Hint: for negative n, you get to choose the behavior. + +rotate_generic amount e = (b ++ a) where + (a, b) = splitAt (amount `rem` (max (length e) 1)) e + +rotate :: Int -> Encoded -> Encoded +rotate amount (Encoded e) = Encoded (rotate_generic amount e) + +-- Problem 6. Come up with an encoding scheme which gets +-- around the problem of the spinning disk. More formally, +-- implement a pair of functions, `encode` and `decode`, so +-- that: +-- +-- 1. Decoding an encoded list of bytes results in the +-- original list, i.e. decode (encode bs) = Just bs. +-- 2. Decoding is rotationally invariant, i.e. +-- decode . rotate n . encode = Just for any positive n. + +header :: [Word8] +header = [(fromIntegral 7), (fromIntegral 47)] + +terminator :: [Word8] +terminator = [(fromIntegral 97), (fromIntegral 178)] + +encoded_size :: [Word8] -> Int +encoded_size d = (2 * (length d)) + (length header) + (length terminator) + +-- encode = 50, 100, 150 + data * 2 + null terminator +encode :: [Word8] -> Encoded +encode d = Encoded (header ++ d ++ d ++ terminator) + + +decode :: Encoded -> Maybe [Word8] +decode (Encoded e) = + if ((maybe_terminator /= terminator) || (maybe_header /= header) || (first /= second)) + then decode (Encoded (rotate_generic 1 e)) + else Just first where + maybe_header = take 2 e + maybe_terminator = reverse (take 2 (reverse e)) + between = tail (tail (init (init e))) + (first, second) = splitAt ((length between) `div` 2) between + +-- Efficiency mark: encoding a list of bytes with length +-- no more than 16 should result in an encoded list of +-- length no more than 37. + + +-- PART 3: FILE SYSTEM HIERARCHY + +-- The rover's in-memory file system is organized into files and +-- directories. Each directory may contain other files and +-- directories inside it. Each file and directory is identified +-- by a unique `Word8`, its UID. + + +-- You can make the following assumptions about the file +-- system of the rover: +-- 1. The total size of all the files is no more than +-- 16kiB (16384 bytes). +-- 2. Every file is at most 3072 bytes long. +-- 3. There are at most 48 files and directories (but their +-- UIDs need not be in the range 0-47) altogether. + + +-- We have decided that one track on the disk will store the +-- contents of at most one file, i.e. that there will not be +-- any tracks which store multiple files. + +-- However, since floppy tracks store only 2048 bytes, and a +-- single file may be longer than 2048 bytes, we will have to +-- come up with a way of storing a single file across multiple +-- tracks. + +-- We will divide each file into a list of chunks, so that each +-- chunk is short enough to be stored in a single track. We will +-- assign each chunk its own unique track. + +-- To reassemble a file, we have to read and decode each of its +-- chunks from the disk in order, then concatenate the results. + +data Chunk = + Chunk TrackNo Encoded deriving (Show, Eq) + +-- Problem 7. Write a stateful function `chunks` which, +-- when given the contents of a file, divides it into +-- a list of `Chunk`s. + +-- The state `n` is a `TrackNo` between 0 and 255, +-- denoting the first track that is still available +-- to store data. E.g. if the state is 12, then +-- tracks 0-11 have already been used to store chunks, +-- but tracks 12-39 are still available. If all tracks +-- have been exhausted, signal the error by assiginng +-- the remaining chunks to track 40. + +split_amount = (2048 `div` 2) - 4 -- encoding is data * 2 + 4 + +tn_max :: TrackNo +tn_max = fromIntegral 40 + +split_into_n :: Int -> [Word8] -> [[Word8]] +split_into_n n d = if (length d) <= n then [d] else [split] ++ concat [(split_into_n n rest)] where + (split, rest) = splitAt n d + +chunks :: [Word8] -> State TrackNo [Chunk] +chunks d = do + tn <- get + put (min (tn + (fromIntegral (length cx))) tn_max) + return (map (\(Chunk tnn ee) -> Chunk (min (tn + tnn) tn_max) ee) cx) where + splits = split_into_n split_amount d + cx = map (\s -> Chunk (fromIntegral (fromJust (elemIndex s splits))) (encode s)) splits + +-- The `FSH t` data type represents a file system hierarchy +-- in which each file is annotated with data of type `t`. +-- For example, `FSH [Word8]` can be used to represent the +-- entire file system, where each file is annotated with its +-- contents (a list of bytes), while the type `FSH ()` can +-- be used to represent just the hierarchical relationships +-- between the files and directories (i.e. which contains +-- which), but without any of the file data. + +-- Problem 8. Write a lawful Functor instance for the FSH +-- type. + +instance Functor FSH where + fmap f (File uid a) = (File uid (f a)) + fmap f (Dir uid arr) = (Dir uid (map (fmap f) arr)) + +--instance Traversable FSH where +-- traverse f (File uid elem) = File uid <$> f elem +-- traverse f (Dir uid arr) = do +-- fx <- fmap (traverse f) arr +-- return $ Dir uid fx + +--instance Traversable FSH where +-- traverse f (File uid elem) = File <$> uid <*> f elem +-- traverse f (Dir uid arr) = Dir <$> uid <*> (map (traverse f) arr) + +--instance Traversable FSH where +-- traverse f (File uid elem) = File <$> uid <*> f elem +-- traverse f (Dir uid arr) = Dir <$> uid <*> (map (\x -> traverse f x) arr) + +--instance Traversable FSH where +-- traverse f (File uid a) = (File uid (f a)) +-- traverse f (Dir uid arr) = (Dir uid (map (traverse f) arr)) + +-- parseElems :: Traversal' Term Term + + + --traverse f (Dir uid arr) = (Dir (uid) (map (\x -> traverse f x) arr)) +-- We will have to save the whole directory hierarchy to +-- disk before the rover is rebooted. So that we can reassemble +-- the hierarchy, we will use Track 0 to store a "header". This +-- header will represent a `FSH [TrackNo]` object, where each +-- file is annotated with the list of tracks that contain its +-- chunks. + +-- The `mkHeader` function below will create this header +-- from a file system hierarchy where each file has been +-- annotated with a list of its chunks (assuming your +-- `Functor` instance is correct). + +mkHeader :: FSH [Chunk] -> FSH [TrackNo] +mkHeader = fmap (map (\(Chunk n _) -> n)) + + +-- Problem 9. Implement a function `assignTracks` which divides +-- all files in a hierarchy into chunks. Each chunk should have +-- be assigned its unique track number. Do not allocate track 0, +-- as that will be used to store the header. +-- Return `Nothing` if the given file system would not fit on +-- tracks 1-39 of a 40-track disk under your encoding. +-- HINT: You'll probably want to have a separate function +-- with return type `State TrackNo (FSH [Chunk])`. + +state_lambda :: [Word8] -> State TrackNo [Chunk] +state_lambda d = do + tn <- get + let (cc, tt) = (runState (chunks d) tn) + put tt + return cc + +--state_tracks :: FSH [Word8] -> State TrackNo (FSH [Chunk]) +--state_tracks fshd = do +-- state <- get + --m <- (mapM (\x -> do + -- c <- chunks x + -- return c + -- ) fshd) + --return m + +-- AHHHHHHHHHHHHHHHHHh +--state_tracks fshd = do + --let asdf = fmap state_lambda fshd + --return (fmap (state_lambda) fshd) + --return (fmap (\x -> evalState (state_lambda x) 1) fshd) + --return (fmap (\x -> evalState (state_lambda x) 1) fshd) + --return (fmap (\c -> do + -- let (cc, tt) = (runState (chunks c) tn) + -- return (head cc)) fshd) + --return (fmap (\c -> do + -- tn <- get + -- let cc = (evalState (chunks c) tn) + -- modify (+ fromIntegral (length cc)) + -- return cc) fshd) where +--fmap' :: FSH [Word8] +--fmap' f (File uid a) = (File uid (f a)) +--fmap' f (Dir uid arr) = (Dir uid (map (fmap f) arr)) + + +--assignTracks :: FSH [Word8] -> Maybe (FSH [Chunk]) +--assignTracks fshd = +-- if (tn >= tn_max) then Nothing else Just tracks where +-- (tracks, tn) = runState (state_tracks fshd) 1 + + +-- PART 4 - DISK CONTROLLER + +-- The disk controller supports four operations: +-- headForward - moves the read/write head forward by 1 track. +-- headBackward - moves the r/w head back toward zero by 1 track. +-- readTrack - reads 2048 consecutive bytes from the current track. +-- writeTrack - writes the given list of bytes to the current track. + +-- In this problem, you will develop a program `saveFSH` that +-- uses this monad to save the entire file system onto the disk. + +-- Problem 10. Write a program `headToTrack` that positions +-- the r/w head of the disk drive on the track with the given +-- number. If the number is larger than 39, position the head +-- on track 39. + +head_forward_n :: (MonadFloppy m) => Word8 -> m () +head_forward_n n = do + if (n > 0) then do + headForward + head_forward_n (n - 1) + else do + return () + +head_backward_n :: (MonadFloppy m) => Word8 -> m () +head_backward_n n = do + if (n > 0) then do + headBackward + head_backward_n (n - 1) + else do + return () + +headToTrack :: (MonadFloppy m) => Word8 -> m () +headToTrack p = do + head_backward_n 40 + head_forward_n p + +-- Problem 11. Write a program `saveChunk` which writes the +-- given chunk onto the appropriate track of the disk. + +saveChunk :: (MonadFloppy m) => Chunk -> m () +saveChunk (Chunk n (Encoded e)) = do + headToTrack n + writeTrack (replicate 2048 0) + writeTrack e + +-- The function below calculates the header of the +-- given given `FSH [Chunk]`, and saves it to track 0 +-- of the disk. Notice the use of the `toBytes` function. + +saveHeader :: (MonadFloppy m) => FSH [Chunk] -> m () +saveHeader fsh = do + headToTrack 0 + writeTrack (replicate 2048 0) + writeTrack (unEncoded $ encode $ toBytes $ mkHeader fsh) + + +-- Problem 12. Implement a program `saveFSH` that attemps to assign +-- track to the given `fsh` using `assignTracks`. If the assignment +-- was unsuccessful, the program should return False. +-- If the assignment was successful, the program should write the +-- header to track 0 of the disk, then write all the assigned chunks +-- onto the appropriate tracks. + +saveFSH :: (MonadFloppy m) => FSH [Word8] -> m Bool +saveFSH = error "'saveFSH' not implemented" + +-- Implement a program `loadFSH` that is able to reload a file +-- system from disk. I.e. if `saveFSH fsh` returns `True`, then +-- (saveFSH fsh >> loadFSH) should return `Just fsh`. +-- HINT: To load the header, you might want to use the `fromBytes` +-- function. + +loadFSH :: (MonadFloppy m) => m (Maybe (FSH [Word8])) +loadFSH = error "'loadFSH' not implemented" diff --git a/comp3141/tortoise/Tortoise.hs b/comp3141/tortoise/Tortoise.hs new file mode 100644 index 0000000..eb06cb2 --- /dev/null +++ b/comp3141/tortoise/Tortoise.hs @@ -0,0 +1,177 @@ +module Tortoise where + +-- COMP3141 22T2 ASSIGNMENT 1 + +import Data.Semigroup +import Data.Function +import Data.List +import Test.QuickCheck + +-- data type definitions + +data Freq = Freq Int deriving (Eq, Ord) +data Interval = Interval Int deriving (Eq, Ord) + +type Count = Integer +data Histogram = Histogram [(Interval, Count)] deriving (Show, Eq) + +data SigCard = + SigCard { + refHistogram :: Histogram, + excluded :: [Interval] + } deriving (Show, Eq) + +data Verdict = RealWeapon | Dud deriving (Show, Eq) + +-- helper functions + +notImpl :: String -> a +notImpl x = error $ "'" ++ x ++ "'" ++ " not defined" + +startPoint :: Interval -> Freq +startPoint (Interval x) = Freq (100*x) + +endPoint :: Interval -> Freq +endPoint (Interval x) = Freq (100*x + 100) + +-- ASSIGNMENT STARTS HERE -- + +-- Problem 1 + +inside :: Freq -> Interval -> Bool +f `inside` i = f >= (startPoint i) && f < (endPoint i) + +intervalOf :: Freq -> Interval +intervalOf (Freq f) = Interval (f `div` 100 - ((f `mod` 100) `div` 100)) + +instance Arbitrary Freq where + arbitrary = do + Positive x <- arbitrary + return $ Freq x + +instance Arbitrary Interval where + arbitrary = do + Positive x <- arbitrary + return $ Interval x + +instance Show Freq where + show (Freq f) = show f +instance Show Interval where + show i = show (startPoint i) ++ " to " ++ show (endPoint i) + +prop_inIntervalOf :: Freq -> Bool +prop_inIntervalOf f = f `inside` (intervalOf f) + +prop_inOneInterval :: Freq -> Interval -> Property +prop_inOneInterval f i = (intervalOf f /= i) ==> (not (f `inside` i)) + +-- Problem 2 + +histogram :: [(Interval, Count)] -> Histogram +histogram h = Histogram ( nubBy (\a b -> fst(a) == fst(b)) (filter (\p -> snd(p) > 0 && fst(p) >= (Interval 0)) (sortBy (compare `on` fst) h))) + +instance Arbitrary Histogram where + arbitrary = do + Positive size <- arbitrary + list <- vector size + return $ histogram (list) + +prop_histogram1 :: Histogram -> Bool -- ascending order +prop_histogram1 (Histogram h) = h == sortBy (compare `on` fst) h + +prop_histogram2 :: Histogram -> Bool -- no zero or negative +prop_histogram2 (Histogram h) = all (\p -> snd(p) > 0 && fst(p) >= (Interval 0)) h + +prop_histogram3 :: Histogram -> Bool -- duplicate keys do not exist +prop_histogram3 (Histogram h) = h == nubBy (\a b -> fst(a) == fst(b)) h + +-- Problem 3 + +process :: [Freq] -> Histogram +process freqs = histogram (map (\i -> (i, fromIntegral (length (filter (\y -> intervalOf y == i) freqs)))) uniq_ints) + where uniq_ints = nub (map (\f -> intervalOf f) freqs) + +merge :: Histogram -> Histogram -> Histogram +merge (Histogram a) (Histogram b) = histogram (map (\p -> (fst(p), fromIntegral (sum $ map (\q -> snd(q)) (filter (\n -> fst(n) == fst(p)) all_hists)))) uniq_hists) + where + all_hists = a ++ b + uniq_hists = nubBy (\a b -> fst(a) == fst(b)) all_hists + +prop_mergeAssoc :: Histogram -> Histogram -> Histogram -> Bool +prop_mergeAssoc a b c = ((a <> b) <> c) == (a <> (b <> c)) + +prop_mergeId :: Histogram -> Bool +prop_mergeId a = (a <> mempty) == a + +prop_mergeComm :: Histogram -> Histogram -> Bool +prop_mergeComm a b = (a <> b) == (b <> a) + +instance Semigroup Histogram where + (<>) = merge + +instance Monoid Histogram where + mappend = (<>) + mempty = histogram [] + +-- Problem 4 + + +is_similar :: Histogram -> Histogram -> Bool +is_similar (Histogram a) (Histogram b) = (sqrt (fromIntegral ((sum non_unique) + (sum unique)))) < 32 where + intersecta = sort (intersectBy (\a b -> fst(a) == fst(b)) a b) + intersectb = sort (intersectBy (\a b -> fst(a) == fst(b)) b a) + non_unique = map (\((_, b), (_, d)) -> (b - d)*(b - d)) (zip intersecta intersectb) + unique = map (\(_, b) -> b*b) ( filter (\p -> not (elem p intersectb)) (filter (\p -> not (elem p intersecta)) a ++ b)) + +prop_test_refl :: Histogram -> Bool +prop_test_refl a = (is_similar a a) == True + +report_refl :: Maybe Histogram +report_refl = Nothing + +prop_test_symm :: Histogram -> Histogram -> Property +prop_test_symm a b = is_similar a b ==> is_similar b a + +report_symm :: Maybe (Histogram, Histogram) +report_symm = Nothing + +report_tran :: Maybe (Histogram, Histogram, Histogram) +report_tran = Just (histogram [(Interval 14, 25)], histogram [], histogram [(Interval 25, 26)]) + +prop_test_tran :: Histogram -> Histogram -> Histogram -> Property +prop_test_tran a b c = (is_similar a b) && (is_similar b c) ==> (is_similar a c) + +-- Inspector O'Hare implemented match as follows: +match :: Histogram -> SigCard -> Verdict +match (Histogram h) (SigCard (Histogram r) v) = + if d < 32 then RealWeapon else Dud where + grab r (Histogram hs) = case filter (\x -> fst x == r) hs of + [(_,x)] -> x + _ -> 0 + squareDist (Histogram h1) (Histogram h2) = sum squares where + common = sort . nub $ map fst h1 ++ map fst h2 + squares = + map (\x -> (fromIntegral $ grab x (Histogram h1) - grab x (Histogram h2))**2) + common + d1 = squareDist (Histogram h) (Histogram r) + h' = Histogram $ filter (\x -> fst x `elem` v) h + r' = Histogram $ filter (\x -> fst x `elem` v) r + d2 = squareDist h' r' + d = sqrt (d1 - d2) + +-- Use this reference card to find a false positive for `match` +refCard :: SigCard +refCard = SigCard (histogram r) v where + r = [(Interval 4, 4000), (Interval 5, 6000), (Interval 6,300)] + v = [Interval 5] + +prop_test_fp :: (Int, Int) -> Property +prop_test_fp (i, j) = ((match unclean_hist refCard) == RealWeapon) ==> (is_similar h (Histogram clean_hist)) where + offset = (Interval 10, 33) + big_num = 16999990000 + unclean_hist = histogram [(Interval 4, 4000), (Interval 6, 300), (Interval 5, big_num), offset] + (Histogram clean_hist) = histogram [(Interval 4, 4000), (Interval 6, 300), offset] + h = histogram [(Interval 4, 4000), (Interval 6, 300)] + +falsePos :: Histogram +falsePos = histogram [(Interval 4, 4000), (Interval 6, 300), (Interval 5, 16999990000), (Interval 10, 33)] |