diff --git a/.ghci b/.ghci index 08306ed..2dd8f91 100644 --- a/.ghci +++ b/.ghci @@ -6,4 +6,5 @@ :set -fno-warn-unused-do-bind :set -fno-warn-unused-imports :set -fno-warn-type-defaults - +:set -XNoImplicitPrelude +:set -XSafe diff --git a/README.markdown b/README.markdown index 6eef059..f13d8d0 100644 --- a/README.markdown +++ b/README.markdown @@ -29,7 +29,7 @@ instructions are not contained herein. You may need to set permissions on a file, `chmod 600 .ghci`. 4. The `Intro` module does not contain exercises. Its purpose is to demonstrate - the structure of a project. The first recommend exercise is `Structure.List`. + the structure of a project. The first recommend exercise is `Course.List`. 5. Edit a source file to a proposed solution to an exercise. At the `ghci` prompt, issue the command `:reload`. This will compile your solution and @@ -131,26 +131,31 @@ compiler error. ### Progression -It is recommended to perform some exercises before others. The first step is to inspect the `Intro` modules. They -contain examples of data structures and Haskell syntax. The next step is to complete the exercises in `Structure.List`. +It is recommended to perform some exercises before others. The first step is to inspect the introduction modules. + +* `Course.Id` +* `Course.Optional` +* `Course.Validation` + +They contain examples of data structures and Haskell syntax. The next step is to complete the exercises in `Course.List`. After this, the following progression of modules is recommended: -* `Monad.Functor` -* `Monad.Monad` -* `Monad.State` -* `Monad.StateT` -* `Structure.ListZipper` -* `Parser.Parser` -* `Parser.MoreParser` -* `Parser.JsonParser` -* `IO.Interactive` -* `Structure.Lens` -* `Algorithm.Anagrams` -* `Algorithm.FastAnagrams` -* `Algorithm.EditDistance` -* `Structure.BKTree` -* `Algorithm.Cheque` +* `Course.Functor` +* `Course.Monad` +* `Course.State` +* `Course.StateT` +* `Course.ListZipper` +* `Course.Parser` +* `Course.MoreParser` +* `Course.JsonParser` +* `Course.Interactive` +* `Course.Lens` +* `Course.Anagrams` +* `Course.FastAnagrams` +* `Course.EditDistance` +* `Course.BKTree` +* `Course.Cheque` After these are completed, complete the exercises in the `projects` directory. diff --git a/course.cabal b/course.cabal index 42e8420..adf4651 100644 --- a/course.cabal +++ b/course.cabal @@ -1,5 +1,5 @@ name: course -version: 0.0.9 +version: 0.1.0 license: BSD3 license-file: etc/LICENCE author: Tony Morris @@ -43,34 +43,37 @@ library -fno-warn-type-defaults default-extensions: Safe + NoImplicitPrelude hs-source-dirs: src exposed-modules: Course - Core - Algorithm.Anagrams - Algorithm.Cheque - Algorithm.EditDistance - Algorithm.FastAnagrams - Intro.Id - Intro.Optional - Intro.Validation - IO.Interactive - Monad.Compose - Monad.Functor - Monad.Monad - Monad.State - Monad.StateT - Parser.JsonParser - Parser.JsonValue - Parser.MoreParser - Parser.Parser - Parser.Person - Structure.BKTree - Structure.Lens - Structure.List - Structure.ListZipper - Structure.MetricSpace + Course.Anagrams + Course.Applicative + Course.Apply + Course.Bind + Course.Cheque + Course.Comonad + Course.Compose + Course.Core + Course.Extend + Course.FastAnagrams + Course.Functor + Course.Id + Course.Interactive + Course.JsonParser + Course.JsonValue + Course.List + Course.ListZipper + Course.Monad + Course.MoreParser + Course.Optional + Course.Parser + Course.Person + Course.State + Course.StateT + Course.Traversable + Course.Validation test-suite doctests type: diff --git a/src/Algorithm/EditDistance.hs b/src/Algorithm/EditDistance.hs deleted file mode 100644 index 0e2ae53..0000000 --- a/src/Algorithm/EditDistance.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Algorithm.EditDistance -( - editDistance -, Edit(..) -, Edits -, diff -, applyDiff -) where - -import Data.Array - -editDistance :: - Eq a => - [a] - -> [a] - -> Int -editDistance = - error "todo" - -data Edit a = - Delete - | Insert a - | Subst a - | Copy - deriving (Eq, Show) - -type Edits a = - [Edit a] - -diff :: - Eq a => - [a] - -> [a] - -> Edits a -diff = - error "todo" - -applyDiff :: - [a] - -> Edits a - -> [a] -applyDiff = - error "todo" - --- do not export - -table :: - Eq a => - [a] - -> [a] - -> Array (Int, Int) Int -table xs ys = - let m = length xs - n = length ys - k i s = (1,i) `array` zip [1..] s - x = k m xs - y = k n ys - - t = b `array` [(z, distance z) | z <- range b] - b = ((0,0),(m,n)) - - distance (0,j) = j - distance (i,0) = i - distance (i,j) = - let track = [(1,0,1),(0,1,1),(1,1, if x ! i == y ! j then 0 else 1)] - in minimum . fmap (\(p, q, o) -> t ! (i-p,j-q) + o) $ track - in t diff --git a/src/Core.hs b/src/Core.hs deleted file mode 100644 index f77a854..0000000 --- a/src/Core.hs +++ /dev/null @@ -1,97 +0,0 @@ -module Core( - ($) - , (.) - , (=<<) - , (>>) - , (||) - , (&&) - , const - , seq - , id - , flip - , not - , otherwise - , fst - , snd - , error - , undefined - , even - , either - , reads - , String - , Char - , Int - , Integer - , IO - , Bool(..) - , Maybe(..) - , Either(..) - , Eq(..) - , Ord(..) - , Show(..) - , Enum(..) - , Num(..) - , Integral(..) - , IsString(..) - , putStr - , putStrLn - , getChar - , getLine - , readFile - , writeFile - , length - , reverse - , foldr - , (++) - ) - where - -import Prelude( - ($) - , (.) - , (=<<) - , (>>) - , (||) - , (&&) - , const - , seq - , id - , flip - , not - , otherwise - , fst - , snd - , error - , undefined - , even - , either - , reads - , String - , Char - , Int - , Integer - , IO - , Bool(..) - , Maybe(..) - , Either(..) - , Eq(..) - , Ord(..) - , Show(..) - , Enum(..) - , Num(..) - , Integral(..) - , putStr - , putStrLn - , getChar - , getLine - , readFile - , writeFile - , length - , reverse - , foldr - , (++) - ) - -import Data.String( - IsString(..) - ) diff --git a/src/Course.hs b/src/Course.hs index 5a08c4a..541b01c 100644 --- a/src/Course.hs +++ b/src/Course.hs @@ -2,27 +2,29 @@ module Course (module X) where -import Core as X -import Algorithm.Anagrams as X -import Algorithm.Cheque as X -import Algorithm.EditDistance as X -import Algorithm.FastAnagrams as X -import Intro.Id as X -import Intro.Optional as X -import Intro.Validation as X -import IO.Interactive as X -import Monad.Compose as X -import Monad.Functor as X -import Monad.Monad as X -import Monad.State as X -import Monad.StateT as X -import Parser.JsonParser as X -import Parser.JsonValue as X -import Parser.MoreParser as X -import Parser.Parser as X -import Parser.Person as X -import Structure.BKTree as X -import Structure.Lens as X -import Structure.List as X -import Structure.ListZipper as X -import Structure.MetricSpace as X +import Course.Anagrams as X +import Course.Applicative as X +import Course.Apply as X +import Course.Bind as X +import Course.Cheque as X +import Course.Comonad as X +import Course.Compose as X +import Course.Core as X +import Course.Extend as X +import Course.FastAnagrams as X +import Course.Functor as X +import Course.Id as X +import Course.Interactive as X +import Course.JsonParser as X +import Course.JsonValue as X +import Course.List as X +import Course.ListZipper as X +import Course.Monad as X +import Course.MoreParser as X +import Course.Optional as X +import Course.Parser as X +import Course.Person as X +import Course.State as X +import Course.StateT as X +import Course.Traversable as X +import Course.Validation as X diff --git a/src/Algorithm/Anagrams.hs b/src/Course/Anagrams.hs similarity index 65% rename from src/Algorithm/Anagrams.hs rename to src/Course/Anagrams.hs index d00ad8f..c897e04 100644 --- a/src/Algorithm/Anagrams.hs +++ b/src/Course/Anagrams.hs @@ -1,13 +1,19 @@ -module Algorithm.Anagrams where +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Course.Anagrams where + +import Course.Core +import Course.List +import Course.Functor {- Functions you will need -- * fmap :: (a -> b) -> IO a -> IO b -* readFile :: FilePath -> IO String -* lines :: String -> [String] +* readFile :: FilePath -> IO Str +* lines :: Str -> [Str] * permutations :: [a] -> [[a]] * intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] * toLower :: Char -> Char @@ -22,16 +28,16 @@ Functions that might help -- Return all anagrams of the given string -- that appear in the given dictionary file. anagrams :: - String - -> FilePath - -> IO [String] + Str + -> Filename + -> IO (List Str) anagrams = error "todo" -- Compare two strings for equality, ignoring case equalIgnoringCase :: - String - -> String + Str + -> Str -> Bool equalIgnoringCase = error "todo" diff --git a/src/Course/Applicative.hs b/src/Course/Applicative.hs new file mode 100644 index 0000000..93ba7cd --- /dev/null +++ b/src/Course/Applicative.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Applicative( + Applicative(..) +, sequence +, replicateA +, filtering +) where + +import Course.Core +import Course.Apply +import Course.Id +import Course.List +import Course.Optional +import qualified Prelude as P + +class Apply f => Applicative f where + pure :: + a -> f a + +-- | Witness that all things with (<*>) and pure also have (<$>). +-- +-- >>> (+1) <$> (Id 2) +-- Id 3 +-- +-- >>> (+1) <$> Nil +-- [] +-- +-- >>> (+1) <$> (1 :. 2 :. 3 :. Nil) +-- [2,3,4] +(<$>) :: + Applicative f => + (a -> b) + -> f a + -> f b +(<$>) = + error "todo" + +-- | Insert into the Id monad. +-- +-- prop> pure x == Id x +instance Applicative Id where + pure = + error "todo" + +-- | Insert into a List. +-- +-- prop> pure x == x :. Nil +instance Applicative List where + pure = + error "todo" + +-- | Insert into an Optional. +-- +-- prop> pure x == Full x +instance Applicative Optional where + pure = + error "todo" + +-- | Insert into a constant function. +-- +-- prop> pure x y == x +instance Applicative ((->) t) where + pure = + error "todo" + +-- | Sequences a list of structures to a structure of list. +-- +-- >>> sequence (Id 7 :. Id 8 :. Id 9 :. Nil) +-- Id [7,8,9] +-- +-- >>> sequence ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) +-- [[1,1],[1,2],[2,1],[2,2],[3,1],[3,2]] +-- +-- >>> sequence (Full 7 :. Empty :. Nil) +-- Empty +-- +-- >>> sequence (Full 7 :. Full 8 :. Nil) +-- Full [7,8] +-- +-- >>> sequence ((*10) :. (+2) :. Nil) 6 +-- [60,8] +sequence :: + Applicative f => + List (f a) + -> f (List a) +sequence = + error "todo" + +-- | Replicate an effect a given number of times. +-- +-- >>> replicateA 4 (Id "hi") +-- Id ["hi","hi","hi","hi"] +-- +-- >>> replicateA 4 (Full "hi") +-- Full ["hi","hi","hi","hi"] +-- +-- >>> replicateA 4 Empty +-- Empty +-- +-- >>> replicateA 4 (*2) 5 +-- [10,10,10,10] +replicateA :: + Applicative f => + Int + -> f a + -> f (List a) +replicateA = + error "todo" + +-- | Filter a list with a predicate that produces an effect. +-- +-- >>> filtering (Id . even) (4 :. 5 :. 6 :. Nil) +-- Id [4,6] +-- +-- >>> filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. Nil) +-- Full [4,5,6] +-- +-- >>> filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. 7 :. 8 :. 9 :. Nil) +-- Full [4,5,6,7] +-- +-- >>> filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. 13 :. 14 :. Nil) +-- Empty +-- +-- >>> filtering (>) (4 :. 5 :. 6 :. 7 :. 8 :. 9 :. 10 :. 11 :. 12 :. Nil) 8 +-- [9,10,11,12] +filtering :: + Applicative f => + (a -> f Bool) + -> List a + -> f (List a) +filtering = + error "todo" + +----------------------- +-- SUPPORT LIBRARIES -- +----------------------- + +instance Applicative IO where + pure = + P.return + +instance Applicative [] where + pure = + P.return + +instance Applicative P.Maybe where + pure = + P.return diff --git a/src/Course/Apply.hs b/src/Course/Apply.hs new file mode 100644 index 0000000..569b87f --- /dev/null +++ b/src/Course/Apply.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Apply where + +import Course.Core +import Course.Functor +import Course.Id +import Course.List +import Course.Optional +import qualified Prelude as P + +class Functor f => Apply f where + (<*>) :: + f (a -> b) + -> f a + -> f b + +infixl 4 <*> + +-- | Implement @Apply@ instance for @Id@. +-- +-- >>> Id (+10) <*> Id 8 +-- Id 18 +instance Apply Id where + (<*>) = + error "todo" + +-- | Implement @Apply@ instance for @List@. +-- +-- >>> (+1) :. (*2) :. Nil <*> 1 :. 2 :. 3 :. Nil +-- [2,3,4,2,4,6] +instance Apply List where + (<*>) = + error "todo" + +-- | Implement @Apply@ instance for @Optional@. +-- +-- >>> Full (+8) <*> Full 7 +-- Full 15 +-- +-- >>> Empty <*> Full 7 +-- Empty +-- +-- >>> Full (+8) <*> Empty +-- Empty +instance Apply Optional where + (<*>) = + error "todo" + +-- | Implement @Apply@ instance for reader. +-- +-- >>> ((+) <*> (+10)) 3 +-- 16 +-- +-- >>> ((+) <*> (+5)) 3 +-- 11 +-- +-- >>> ((+) <*> (+5)) 1 +-- 7 +-- +-- >>> ((*) <*> (+10)) 3 +-- 39 +-- +-- >>> ((*) <*> (+2)) 3 +-- 15 +instance Apply ((->) t) where + (<*>) = + error "todo" + +-- | Apply a binary function in the environment. +-- +-- >>> lift2 (+) (Id 7) (Id 8) +-- Id 15 +-- +-- >>> lift2 (+) (1 :. 2 :. 3 :. Nil) (4 :. 5 :. Nil) +-- [5,6,6,7,7,8] +-- +-- >>> lift2 (+) (Full 7) (Full 8) +-- Full 15 +-- +-- >>> lift2 (+) (Full 7) Empty +-- Empty +-- +-- >>> lift2 (+) Empty (Full 8) +-- Empty +-- +-- >>> lift2 (+) length sum (listh [4,5,6]) +-- 18 +lift2 :: + Apply f => + (a -> b -> c) + -> f a + -> f b + -> f c +lift2 = + error "todo" + +-- | Apply a ternary function in the Monad environment. +-- +-- >>> lift3 (\a b c -> a + b + c) (Id 7) (Id 8) (Id 9) +-- Id 24 +-- +-- >>> lift3 (\a b c -> a + b + c) (1 :. 2 :. 3 :. Nil) (4 :. 5 :. Nil) (6 :. 7 :. 8 :. Nil) +-- [11,12,13,12,13,14,12,13,14,13,14,15,13,14,15,14,15,16] +-- +-- >>> lift3 (\a b c -> a + b + c) (Full 7) (Full 8) (Full 9) +-- Full 24 +-- +-- >>> lift3 (\a b c -> a + b + c) (Full 7) (Full 8) Empty +-- Empty +-- +-- >>> lift3 (\a b c -> a + b + c) Empty (Full 8) (Full 9) +-- Empty +-- +-- >>> lift3 (\a b c -> a + b + c) Empty Empty (Full 9) +-- Empty +-- +-- >>> lift3 (\a b c -> a + b + c) length sum product (listh [4,5,6]) +-- 138 +lift3 :: + Apply f => + (a -> b -> c -> d) + -> f a + -> f b + -> f c + -> f d +lift3 = + error "todo" + +-- | Apply a quaternary function in the environment. +-- +-- >>> lift4 (\a b c d -> a + b + c + d) (Id 7) (Id 8) (Id 9) (Id 10) +-- Id 34 +-- +-- >>> lift4 (\a b c d -> a + b + c + d) (1 :. 2 :. 3 :. Nil) (4 :. 5 :. Nil) (6 :. 7 :. 8 :. Nil) (9 :. 10 :. Nil) +-- [20,21,21,22,22,23,21,22,22,23,23,24,21,22,22,23,23,24,22,23,23,24,24,25,22,23,23,24,24,25,23,24,24,25,25,26] +-- +-- >>> lift4 (\a b c d -> a + b + c + d) (Full 7) (Full 8) (Full 9) (Full 10) +-- Full 34 +-- +-- >>> lift4 (\a b c d -> a + b + c + d) (Full 7) (Full 8) Empty (Full 10) +-- Empty +-- +-- >>> lift4 (\a b c d -> a + b + c + d) Empty (Full 8) (Full 9) (Full 10) +-- Empty +-- +-- >>> lift4 (\a b c d -> a + b + c + d) Empty Empty (Full 9) (Full 10) +-- Empty +-- +-- >>> lift4 (\a b c d -> a + b + c + d) length sum product (sum . filter even) (listh [4,5,6]) +-- 148 +lift4 :: + Apply f => + (a -> b -> c -> d -> e) + -> f a + -> f b + -> f c + -> f d + -> f e +lift4 = + error "todo" + +-- | Sequence, discarding the value of the first argument. +-- +-- [1,2,3] *> [4,5,6] +-- [4,5,6,4,5,6,4,5,6] +-- +-- Full 7 *> Full 8 +-- Full 8 +-- +-- prop> [a,b,c] *> [x,y,z] == [x,y,z,x,y,z,x,y,z] +-- +-- prop> Full x *> Full y == Full y +(*>) :: + Apply f => + f a + -> f b + -> f b +(*>) = + error "todo" + +-- | Sequence, discarding the value of the second argument. +-- +-- [1,2,3] *> [4,5,6] +-- [1,2,3,1,2,3,1,2,3] +-- +-- Full 7 *> Full 8 +-- Full 7 +-- +-- prop> [x,y,z] *> [a,b,c] == [x,y,z,x,y,z,x,y,z] +-- +-- prop> Full x *> Full y == Full x +(<*) :: + Apply f => + f b + -> f a + -> f b +(<*) = + error "todo" + +----------------------- +-- SUPPORT LIBRARIES -- +----------------------- + +instance Apply IO where + f <*> a = + f P.>>= \f' -> P.fmap (f' $) a + +instance Apply [] where + f <*> a = + f P.>>= \f' -> P.fmap (f' $) a + +instance Apply P.Maybe where + f <*> a = + f P.>>= \f' -> P.fmap (f' $) a diff --git a/src/Course/Bind.hs b/src/Course/Bind.hs new file mode 100644 index 0000000..f9c0db0 --- /dev/null +++ b/src/Course/Bind.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Bind( + Bind(..) +, (>>=) +, join +) where + +import Course.Core +import Course.Functor +import Course.Apply(Apply) +import Course.Id +import Course.List +import Course.Optional +import qualified Prelude as P + +class Apply f => Bind f where + (=<<) :: + (a -> f b) + -> f a + -> f b + +infixr 1 =<< + +-- | Witness that all things with (=<<) and (<$>) also have (<*>). +-- +-- >>> Id (+10) <*> Id 8 +-- Id 18 +-- +-- >>> (+1) :. (*2) :. Nil <*> 1 :. 2 :. 3 :. Nil +-- [2,3,4,2,4,6] +-- +-- >>> Full (+8) <*> Full 7 +-- Full 15 +-- +-- >>> Empty <*> Full 7 +-- Empty +-- +-- >>> Full (+8) <*> Empty +-- Empty +-- +-- >>> ((+) <*> (+10)) 3 +-- 16 +-- +-- >>> ((+) <*> (+5)) 3 +-- 11 +-- +-- >>> ((+) <*> (+5)) 1 +-- 7 +-- +-- >>> ((*) <*> (+10)) 3 +-- 39 +-- +-- >>> ((*) <*> (+2)) 3 +-- 15 +(<*>) :: + Bind f => + f (a -> b) + -> f a + -> f b +(<*>) = + error "todo" + +infixl 4 <*> + +-- | Binds a function on the Id monad. +-- +-- >>> (\x -> Id(x+1)) =<< Id 2 +-- Id 3 +instance Bind Id where + (=<<) = + error "todo" + +-- | Binds a function on a List. +-- +-- >>> (\n -> n :. n :. Nil) =<< (1 :. 2 :. 3 :. Nil) +-- [1,1,2,2,3,3] +instance Bind List where + (=<<) = + error "todo" + +-- | Binds a function on an Optional. +-- +-- >>> (\n -> Full (n + n)) =<< Full 7 +-- Full 14 +instance Bind Optional where + (=<<) = + error "todo" + +-- | Binds a function on the reader ((->) t). +-- +-- >>> ((*) =<< (+10)) 7 +-- 119 +instance Bind ((->) t) where + (=<<) = + error "todo" + +-- | Flattens a combined structure to a single structure. +-- +-- >>> join ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) +-- [1,2,3,1,2] +-- +-- >>> join (Full Empty) +-- Empty +-- +-- >>> join (Full (Full 7)) +-- Full 7 +-- +-- >>> join (+) 7 +-- 14 +join :: + Bind f => + f (f a) + -> f a +join = + error "todo" + +-- | Implement a flipped version of @(=<<)@, however, use only +-- @join@ and @(<$>)@. +(>>=) :: + Bind f => + f a + -> (a -> f b) + -> f b +(>>=) = + error "todo" + +infixl 1 >>= + +----------------------- +-- SUPPORT LIBRARIES -- +----------------------- + +instance Bind IO where + (=<<) = + (P.=<<) + +instance Bind [] where + (=<<) = + (P.=<<) + +instance Bind P.Maybe where + (=<<) = + (P.=<<) diff --git a/src/Algorithm/Cheque.hs b/src/Course/Cheque.hs similarity index 90% rename from src/Algorithm/Cheque.hs rename to src/Course/Cheque.hs index 37c32c5..272197e 100644 --- a/src/Algorithm/Cheque.hs +++ b/src/Course/Cheque.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + {- Write a function (dollars) that accepts a `String` and returns a `String`. @@ -13,21 +16,23 @@ data structures that may assist you in deriving the result. It is not compulsory -} -module Algorithm.Cheque where +module Course.Cheque where -import Data.Maybe -import Data.Char -import Data.List -import Control.Applicative +import Course.Core +import Course.Optional +import Course.List +import Course.Functor +import Course.Apply +import Course.Bind -- The representation of the grouping of each exponent of one thousand. ["thousand", "million", ...] illion :: - [String] + List Str illion = let preillion :: - [String -> String] + List (Str -> Str) preillion = - [ + listh [ const "" , const "un" , const "do" @@ -40,9 +45,9 @@ illion = , \q -> if "n" `isPrefixOf` q then "novem" else "noven" ] postillion :: - [String] + List Str postillion = - [ + listh [ "vigintillion" , "trigintillion" , "quadragintillion" @@ -142,7 +147,7 @@ illion = , "octogintanongentillion" , "nonagintanongentillion" ] - in [ + in listh [ "" , "thousand" , "million" @@ -164,7 +169,7 @@ illion = , "septendecillion" , "octodecillion" , "novemdecillion" - ] ++ liftA2 ((++) =<<) preillion postillion + ] ++ lift2 ((++) =<<) preillion postillion -- A data type representing the digits zero to nine. data Digit = @@ -178,7 +183,31 @@ data Digit = | Seven | Eight | Nine - deriving (Show, Eq, Enum, Bounded) + deriving (Eq, Enum, Bounded) + +showDigit :: + Digit + -> Str +showDigit Zero = + "zero" +showDigit One = + "one" +showDigit Two = + "two" +showDigit Three = + "three" +showDigit Four = + "four" +showDigit Five = + "five" +showDigit Six = + "six" +showDigit Seven = + "seven" +showDigit Eight = + "eight" +showDigit Nine = + "nine" -- A data type representing one, two or three digits, which may be useful for grouping. data Digit3 = @@ -190,29 +219,29 @@ data Digit3 = -- Possibly convert a character to a digit. fromChar :: Char - -> Maybe Digit + -> Optional Digit fromChar '0' = - Just Zero + Full Zero fromChar '1' = - Just One + Full One fromChar '2' = - Just Two + Full Two fromChar '3' = - Just Three + Full Three fromChar '4' = - Just Four + Full Four fromChar '5' = - Just Five + Full Five fromChar '6' = - Just Six + Full Six fromChar '7' = - Just Seven + Full Seven fromChar '8' = - Just Eight + Full Eight fromChar '9' = - Just Nine + Full Nine fromChar _ = - Nothing + Empty -- | Take a numeric value and produce its English output. -- @@ -288,7 +317,7 @@ fromChar _ = -- >>> dollars "456789123456789012345678901234567890123456789012345678901234567890.12" -- "four hundred and fifty-six vigintillion seven hundred and eighty-nine novemdecillion one hundred and twenty-three octodecillion four hundred and fifty-six septendecillion seven hundred and eighty-nine sexdecillion twelve quindecillion three hundred and forty-five quattuordecillion six hundred and seventy-eight tredecillion nine hundred and one duodecillion two hundred and thirty-four undecillion five hundred and sixty-seven decillion eight hundred and ninety nonillion one hundred and twenty-three octillion four hundred and fifty-six septillion seven hundred and eighty-nine sextillion twelve quintillion three hundred and forty-five quadrillion six hundred and seventy-eight trillion nine hundred and one billion two hundred and thirty-four million five hundred and sixty-seven thousand eight hundred and ninety dollars and twelve cents" dollars :: - String - -> String + Str + -> Str dollars = error "todo" diff --git a/src/Course/Comonad.hs b/src/Course/Comonad.hs new file mode 100644 index 0000000..e774b42 --- /dev/null +++ b/src/Course/Comonad.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Comonad +( + Comonad(..) +) where + +import Course.Core +import Course.Extend +import Course.Id + +class Extend f => Comonad f where + copure :: + f a + -> a + +-- | Implement the @Comonad@ instance for @Id@. +-- +-- >>> copure (Id 7) +-- 7 +instance Comonad Id where + copure = + error "todo" + +-- | Witness that all things with (<<=) and copure also have (<$>). +-- +-- (+10) <$> Id 7 +-- 17 +(<$>) :: + Comonad f => + (a -> b) + -> f a + -> f b +(<$>) = + error "todo" diff --git a/src/Course/Compose.hs b/src/Course/Compose.hs new file mode 100644 index 0000000..ebd3e02 --- /dev/null +++ b/src/Course/Compose.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Compose where + +import Course.Core +import Course.Functor +import Course.Apply +import Course.Applicative +import Course.Bind + +-- Exactly one of these exercises will not be possible to achieve. Determine which. + +newtype Compose f g a = + Compose (f (g a)) + +-- Implement a Functor instance for Compose +instance (Functor f, Functor g) => + Functor (Compose f g) where + (<$>) = + error "todo" + +instance (Apply f, Apply g) => + Apply (Compose f g) where +-- Implement the (<*>) function for an Apply instance for Compose + (<*>) = + error "todo" + +instance (Applicative f, Applicative g) => + Applicative (Compose f g) where +-- Implement the pure function for an Applicative instance for Compose + pure = + error "todo" + +instance (Bind f, Bind g) => + Bind (Compose f g) where +-- Implement the (=<<) function for a Bind instance for Compose + (=<<) = + error "todo" diff --git a/src/Course/Core.hs b/src/Course/Core.hs new file mode 100644 index 0000000..e7a6c4c --- /dev/null +++ b/src/Course/Core.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Core( + Eq(..) +, Ord(..) +, Show(..) +, Enum(..) +, Integral(..) +, Bounded(..) +, RealFrac(..) +, Num(..) +, Bool(..) +, Either(..) +, Int +, Integer +, IO +, Rational +, seq +, error +, undefined +, const +, flip +, id +, otherwise +, (.) +, ($) +, (&&) +, (||) +, not +, even +, odd +, fst +, snd +, getChar +, on +, IsString(..) +, module Data.Char +) where + + +import Prelude( + Eq(..) + , Ord(..) + , Show(..) + , Enum(..) + , Integral(..) + , Bounded(..) + , RealFrac(..) + , Num(..) + , Bool(..) + , Either(..) + , Char + , Int + , Integer + , IO + , Rational + , seq + , error + , undefined + , const + , flip + , id + , otherwise + , (.) + , ($) + , (&&) + , (||) + , not + , even + , odd + , fst + , snd + ) +import Data.String( + IsString(..) + ) + +import System.IO( + getChar + ) +import Data.Function( + on + ) +import Data.Char diff --git a/src/Course/Extend.hs b/src/Course/Extend.hs new file mode 100644 index 0000000..f3c3db4 --- /dev/null +++ b/src/Course/Extend.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Extend where + +import Course.Core +import Course.Id +import Course.List +import Course.Optional +import Course.Functor + +class Functor f => Extend f where + (<<=) :: + (f a -> b) + -> f a + -> f b + +infixr 1 <<= + +-- | Implement the @Extend@ instance for @Id@. +-- +-- >>> id <<= Id 7 +-- Id (Id 7) +instance Extend Id where + f <<= i = + Id (f i) + +-- | Implement the @Extend@ instance for @List@. +-- +-- >>> length <<= ('a' :. 'b' :. 'c' :. Nil) +-- [3,2,1] +-- +-- >>> id <<= (1 :. 2 :. 3 :. 4 :. Nil) +-- [[1,2,3,4],[2,3,4],[3,4],[4]] +-- +-- > reverse =<< ((1 :. 2 :. 3 :. Nil) :. (4 :. 5 :. 6 :. Nil) :. Nil) +-- [3,2,1,6,5,4] +instance Extend List where + _ <<= Nil = + Nil + f <<= x@(_ :. t) = + f x :. (f <<= t) + +-- | Implement the @Extend@ instance for @Optional@. +-- +-- >>> id <<= (Full 7) +-- Full (Full 7) +-- +-- >>> id <<= Empty +-- Empty +instance Extend Optional where + f <<= o = + f . Full <$> o + +-- | Duplicate the functor using extension. +-- +-- >>> cojoin (Id 7) +-- Id (Id 7) +-- +-- >>> cojoin (1 :. 2 :. 3 :. 4 :. Nil) +-- [[1,2,3,4],[2,3,4],[3,4],[4]] +-- +-- >>> cojoin (Full 7) +-- Full (Full 7) +-- +-- >>> cojoin Empty +-- Empty +cojoin :: + Extend f => + f a + -> f (f a) +cojoin = + error "todo" diff --git a/src/Algorithm/FastAnagrams.hs b/src/Course/FastAnagrams.hs similarity index 64% rename from src/Algorithm/FastAnagrams.hs rename to src/Course/FastAnagrams.hs index dd414a6..b08b0cd 100644 --- a/src/Algorithm/FastAnagrams.hs +++ b/src/Course/FastAnagrams.hs @@ -1,22 +1,24 @@ -module Algorithm.FastAnagrams where +{-# LANGUAGE NoImplicitPrelude #-} -import Data.Char -import Data.Function +module Course.FastAnagrams where + +import Course.Core +import Course.List +import Course.Functor import qualified Data.Set as S -import Data.List -- Return all anagrams of the given string -- that appear in the given dictionary file. fastAnagrams :: - String - -> FilePath - -> IO [String] + Str + -> Filename + -> IO (List Str) fastAnagrams = error "todo" newtype NoCaseString = NoCaseString { - ncString :: String + ncString :: Str } instance Eq NoCaseString where diff --git a/src/Course/Functor.hs b/src/Course/Functor.hs new file mode 100644 index 0000000..831d627 --- /dev/null +++ b/src/Course/Functor.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Functor where + +import Course.Core +import Course.Id +import Course.Optional +import Course.List +import qualified Prelude as P + +class Functor f where + (<$>) :: + (a -> b) + -> f a + -> f b + +infixl 4 <$> + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Course.Core +-- >>> import qualified Prelude as P(return, (>>)) + +-- | Maps a function on the Id functor. +-- +-- >>> (+1) <$> Id 2 +-- Id 3 +instance Functor Id where + (<$>) = + error "todo" + +-- | Maps a function on the List functor. +-- +-- >>> (+1) <$> Nil +-- [] +-- +-- >>> (+1) <$> (1 :. 2 :. 3 :. Nil) +-- [2,3,4] +instance Functor List where + (<$>) = + error "todo" + +-- | Maps a function on the Optional functor. +-- +-- >>> (+1) <$> Empty +-- Empty +-- +-- >>> (+1) <$> Full 2 +-- Full 3 +instance Functor Optional where + (<$>) = + error "todo" + +-- | Maps a function on the reader ((->) t) functor. +-- +-- >>> ((+1) <$> (*2)) 8 +-- 17 +instance Functor ((->) t) where + (<$>) = + error "todo" + +-- | Anonymous map. Maps a constant value on a functor. +-- +-- >>> 7 <$ [1,2,3] +-- [7,7,7] +-- +-- prop> x <$ [a,b,c] == [x,x,x] +-- +-- prop> x <$ Full q == Full x +(<$) :: + Functor f => + a + -> f b + -> f a +(<$) = + error "todo" + +----------------------- +-- SUPPORT LIBRARIES -- +----------------------- + +-- | Maps a function on an IO program. +-- +-- >>> reverse <$> (putStr "hi" P.>> P.return ("abc" :: List Char)) +-- hi"cba" +instance Functor IO where + (<$>) = + P.fmap + +instance Functor [] where + (<$>) = + P.fmap + +instance Functor P.Maybe where + (<$>) = + P.fmap diff --git a/src/Intro/Id.hs b/src/Course/Id.hs similarity index 52% rename from src/Intro/Id.hs rename to src/Course/Id.hs index c4dc83d..41c37ad 100644 --- a/src/Intro/Id.hs +++ b/src/Course/Id.hs @@ -1,4 +1,9 @@ -module Intro.Id where +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Id where + +import Course.Core +import qualified Prelude as P data Id a = Id a deriving (Eq, Show) @@ -10,3 +15,9 @@ mapId f (Id a) = Id (f a) bindId :: (a -> Id b) -> Id a -> Id b bindId f (Id a) = f a + +instance P.Monad Id where + (>>=) = + flip bindId + return = + Id diff --git a/src/IO/Interactive.hs b/src/Course/Interactive.hs similarity index 81% rename from src/IO/Interactive.hs rename to src/Course/Interactive.hs index 5640dfd..2a0556d 100644 --- a/src/IO/Interactive.hs +++ b/src/Course/Interactive.hs @@ -1,13 +1,16 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} -module IO.Interactive where +module Course.Interactive where -import Core -import Monad.Functor -import Monad.Monad -import Data.Char -import Structure.List -import Intro.Optional +import Course.Core +import Course.Functor +import Course.Applicative +import Course.Bind +import Course.Monad +import Course.Traversable +import Course.List +import Course.Optional -- | Eliminates any value over which a functor is defined. vooid :: @@ -15,9 +18,7 @@ vooid :: m a -> m () vooid = - let m = fmap - -- to avoid hlint warning - in m (const ()) + (<$>) (const ()) -- | A version of @bind@ that ignores the result of the effect. (>-) :: @@ -26,16 +27,7 @@ vooid = -> m b -> m b (>-) a = - (>>-) a . const - --- | An infix, flipped version of @bind@. -(>>-) :: - Monad m => - m a - -> (a -> m b) - -> m b -(>>-) = - flip bind + (>>=) a . const -- | Runs an action until a result of that action satisfies a given predicate. untilM :: @@ -44,11 +36,11 @@ untilM :: -> m a -- ^ The action to run until the predicate satisfies. -> m a untilM p a = - a >>- \r -> - p r >>- \q -> + a >>= \r -> + p r >>= \q -> if q then - return r + pure r else untilM p a @@ -61,19 +53,18 @@ echo = if c == 'q' then putStrLn "Bye!" >- - return True + pure True else - return False) + pure False) (putStr "Enter a character: " >- - getChar >>- \c -> + getChar >>= \c -> putStrLn "" >- - putStrLn [c] >- - return c)) + putStrLn (c :. Nil) >- + pure c)) data Op = - Op Char String (IO ()) -- keyboard entry, description, program + Op Char Str (IO ()) -- keyboard entry, description, program --- Exercise 1 -- | -- -- * Ask the user to enter a string to convert to upper-case. @@ -94,7 +85,6 @@ convertInteractive :: convertInteractive = error "todo" --- Exercise 2 -- | -- -- * Ask the user to enter a file name to reverse. @@ -123,7 +113,6 @@ reverseInteractive :: reverseInteractive = error "todo" --- Exercise 3 -- | -- -- * Ask the user to enter a string to url-encode. @@ -157,7 +146,7 @@ interactive = Op 'c' "Convert a string to upper-case" convertInteractive :. Op 'r' "Reverse a file" reverseInteractive :. Op 'e' "Encode a URL" encodeInteractive - :. Op 'q' "Quit" (return ()) + :. Op 'q' "Quit" (pure ()) :. Nil ) in vooid (untilM @@ -165,18 +154,18 @@ interactive = if c == 'q' then putStrLn "Bye!" >- - return True + pure True else - return False) + pure False) (putStrLn "Select: " >- - traaverse (\(Op c s _) -> - putStr [c] >- + traverse (\(Op c s _) -> + putStr (c :. Nil) >- putStr ". " >- putStrLn s) ops >- - getChar >>- \c -> + getChar >>= \c -> putStrLn "" >- let o = find (\(Op c' _ _) -> c' == c) ops r = case o of Empty -> (putStrLn "Not a valid selection. Try again." >-) Full (Op _ _ k) -> (k >-) - in r (return c))) + in r (pure c))) diff --git a/src/Parser/JsonParser.hs b/src/Course/JsonParser.hs similarity index 89% rename from src/Parser/JsonParser.hs rename to src/Course/JsonParser.hs index b0f6f88..588e05e 100644 --- a/src/Parser/JsonParser.hs +++ b/src/Course/JsonParser.hs @@ -1,12 +1,21 @@ -module Parser.JsonParser where +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} -import Parser.Parser -import Parser.MoreParser -import Numeric -import Parser.JsonValue -import Control.Applicative +module Course.JsonParser where + +import Course.Core +import Course.Parser +import Course.MoreParser +import Course.JsonValue +import Course.Functor +import Course.Apply +import Course.Applicative +import Course.List +import Course.Optional + +-- $setup +-- >>> :set -XOverloadedStrings --- Exercise 1 -- | Parse a JSON string. Handle double-quotes, control characters, hexadecimal characters. -- -- /Tip:/ Use `oneof`, `hex`, `is`, `satisfyAll`, `betweenCharTok`, `list`. @@ -35,14 +44,13 @@ import Control.Applicative -- >>> isErrorResult (parse jsonString "\"\\abc\"def") -- True jsonString :: - Parser String + Parser Str jsonString = error "todo" --- Exercise 2 -- | Parse a JSON rational. -- --- /Tip:/ Use @Numeric#readSigned@ and @Numeric#readFloat@. +-- /Tip:/ Use @readFloats@. -- -- >>> parse jsonNumber "234" -- Result >< 234 % 1 @@ -69,7 +77,6 @@ jsonNumber :: jsonNumber = error "todo" --- Exercise 3 -- | Parse a JSON true literal. -- -- /Tip:/ Use `stringTok`. @@ -80,11 +87,10 @@ jsonNumber = -- >>> isErrorResult (parse jsonTrue "TRUE") -- True jsonTrue :: - Parser String + Parser Str jsonTrue = error "todo" --- Exercise 4 -- | Parse a JSON false literal. -- -- /Tip:/ Use `stringTok`. @@ -95,11 +101,10 @@ jsonTrue = -- >>> isErrorResult (parse jsonFalse "FALSE") -- True jsonFalse :: - Parser String + Parser Str jsonFalse = error "todo" --- Exercise 5 -- | Parse a JSON null literal. -- -- /Tip:/ Use `stringTok`. @@ -110,11 +115,10 @@ jsonFalse = -- >>> isErrorResult (parse jsonNull "NULL") -- True jsonNull :: - Parser String + Parser Str jsonNull = error "todo" --- Exercise 6 -- | Parse a JSON array. -- -- /Tip:/ Use `betweenSepbyComma` and `jsonValue`. @@ -134,11 +138,10 @@ jsonNull = -- >>> parse jsonArray "[true, \"abc\", [false]]" -- Result >< [JsonTrue,JsonString "abc",JsonArray [JsonFalse]] jsonArray :: - Parser [JsonValue] + Parser (List JsonValue) jsonArray = error "todo" --- Exercise 7 -- | Parse a JSON object. -- -- /Tip:/ Use `jsonString`, `charTok`, `betweenSepbyComma` and `jsonValue`. @@ -159,7 +162,6 @@ jsonObject :: jsonObject = error "todo" --- Exercise 8 -- | Parse a JSON value. -- -- /Tip:/ Use `spaces`, `jsonNull`, `jsonTrue`, `jsonFalse`, `jsonArray`, `jsonString`, `jsonObject` and `jsonNumber`. @@ -177,12 +179,11 @@ jsonValue :: jsonValue = error "todo" --- Exercise 9 -- | Read a file into a JSON value. -- -- /Tip:/ Use @System.IO#readFile@ and `jsonValue`. readJsonValue :: - FilePath + Filename -> IO (ParseResult JsonValue) readJsonValue = error "todo" diff --git a/src/Course/JsonValue.hs b/src/Course/JsonValue.hs new file mode 100644 index 0000000..04a76a7 --- /dev/null +++ b/src/Course/JsonValue.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.JsonValue where + +import Course.Core +import Course.List + +type Assoc = List (Str, JsonValue) + +data JsonValue = + JsonString Str + | JsonRational Bool !Rational + | JsonObject Assoc + | JsonArray (List JsonValue) + | JsonTrue + | JsonFalse + | JsonNull + deriving (Show, Eq) diff --git a/src/Course/List.hs b/src/Course/List.hs new file mode 100644 index 0000000..2e780c9 --- /dev/null +++ b/src/Course/List.hs @@ -0,0 +1,621 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +-- + Complete the 10 exercises below by filling out the function bodies. +-- Replace the function bodies (error "todo") with an appropriate solution. +-- + These exercises may be done in any order, however: +-- Exercises are generally increasing in difficulty, though some people may find later exercise easier. +-- + Bonus for using the provided functions or for using one exercise solution to help solve another. +-- + Approach with your best available intuition; just dive in and do what you can! + +module Course.List where + +import Course.Core +import Course.Optional +import qualified Prelude as P +import qualified Numeric as N + + +-- $setup +-- >>> import Test.QuickCheck +-- >>> import Course.Core(even, id, const) +-- >>> import qualified Prelude as P(fmap, foldr) +-- >>> instance Arbitrary a => Arbitrary (List a) where arbitrary = P.fmap (P.foldr (:.) Nil) arbitrary + +-- BEGIN Helper functions and data types + +-- The custom list type +data List t = + Nil + | t :. List t + deriving (Eq, Ord) + +-- Right-associative +infixr 5 :. + +instance Show t => Show (List t) where + show = show . foldRight (:) [] + +-- The list of integers from zero to infinity. +infinity :: + List Integer +infinity = + let inf x = x :. inf (x+1) + in inf 0 + +-- functions over List that you may consider using +foldRight :: (a -> b -> b) -> b -> List a -> b +foldRight _ b Nil = b +foldRight f b (h :. t) = f h (foldRight f b t) + +foldLeft :: (b -> a -> b) -> b -> List a -> b +foldLeft _ b Nil = b +foldLeft f b (h :. t) = let b' = f b h in b' `seq` foldLeft f b' t + +-- END Helper functions and data types + +-- | Returns the head of the list or the given default. +-- +-- >>> headOr 3 (1 :. 2 :. Nil) +-- 1 +-- +-- >>> headOr 3 Nil +-- 3 +-- +-- prop> x `headOr` infinity == 0 +-- +-- prop> x `headOr` Nil == x +headOr :: + a + -> List a + -> a +headOr = + error "todo" + +-- | The product of the elements of a list. +-- +-- >>> product (1 :. 2 :. 3 :. Nil) +-- 6 +-- +-- >>> product (1 :. 2 :. 3 :. 4 :. Nil) +-- 24 +product :: + List Int + -> Int +product = + error "todo" + +-- | Sum the elements of the list. +-- +-- >>> sum (1 :. 2 :. 3 :. Nil) +-- 6 +-- +-- >>> sum (1 :. 2 :. 3 :. 4 :. Nil) +-- 10 +-- +-- prop> foldLeft (-) (sum x) x == 0 +sum :: + List Int + -> Int +sum = + error "todo" + +-- | Return the length of the list. +-- +-- >>> length (1 :. 2 :. 3 :. Nil) +-- 3 +-- +-- prop> sum (map (const 1) x) == length x +length :: + List a + -> Int +length = + error "todo" + +-- | Map the given function on each element of the list. +-- +-- >>> map (+10) (1 :. 2 :. 3 :. Nil) +-- [11,12,13] +-- +-- prop> headOr x (map (+1) infinity) == 1 +-- +-- prop> map id x == x +map :: + (a -> b) + -> List a + -> List b +map = + error "todo" + +-- | Return elements satisfying the given predicate. +-- +-- >>> filter even (1 :. 2 :. 3 :. 4 :. 5 :. Nil) +-- [2,4] +-- +-- prop> headOr x (filter (const True) infinity) == 0 +-- +-- prop> filter (const True) x == x +-- +-- prop> filter (const False) x == Nil +filter :: + (a -> Bool) + -> List a + -> List a +filter = + error "todo" + +-- | Append two lists to a new list. +-- +-- >>> (1 :. 2 :. 3 :. Nil) ++ (4 :. 5 :. 6 :. Nil) +-- [1,2,3,4,5,6] +-- +-- prop> headOr x (Nil ++ infinity) == 0 +-- +-- prop> headOr x (y ++ infinity) == headOr 0 y +-- +-- prop> (x ++ y) ++ z == x ++ (y ++ z) +-- +-- prop> x ++ Nil == x +(++) :: + List a + -> List a + -> List a +(++) = + error "todo" + +infixr 5 ++ + +-- | Flatten a list of lists to a list. +-- +-- >>> flatten ((1 :. 2 :. 3 :. Nil) :. (4 :. 5 :. 6 :. Nil) :. (7 :. 8 :. 9 :. Nil) :. Nil) +-- [1,2,3,4,5,6,7,8,9] +-- +-- prop> headOr x (flatten (infinity :. y :. Nil)) == 0 +-- +-- prop> headOr x (flatten (y :. infinity :. Nil)) == headOr 0 y +-- +-- prop> sum (map length x) == length (flatten x) +flatten :: + List (List a) + -> List a +flatten = + error "todo" + +-- | Map a function then flatten to a list. +-- +-- >>> flatMap (\x -> x :. x + 1 :. x + 2 :. Nil) (1 :. 2 :. 3 :. Nil) +-- [1,2,3,2,3,4,3,4,5] +-- +-- prop> headOr x (flatMap id (infinity :. y :. Nil)) == 0 +-- +-- prop> headOr x (flatMap id (y :. infinity :. Nil)) == headOr 0 y +-- +-- prop> flatMap id (x :: List (List Int)) == flatten x +flatMap :: + (a -> List b) + -> List a + -> List b +flatMap = + error "todo" + +-- | Convert a list of optional values to an optional list of values. +-- +-- * If the list contains all `Full` values, +-- then return `Full` list of values. +-- +-- * If the list contains one or more `Empty` values, +-- then return `Empty`. +-- +-- * The only time `Empty` is returned is +-- when the list contains one or more `Empty` values. +-- +-- >>> seqOptional (Full 1 :. Full 10 :. Nil) +-- Full [1,10] +-- +-- >>> seqOptional Nil +-- Full [] +-- +-- >>> seqOptional (Full 1 :. Full 10 :. Empty :. Nil) +-- Empty +-- +-- >>> seqOptional (Empty :. map Full infinity) +-- Empty +seqOptional :: + List (Optional a) + -> Optional (List a) +seqOptional = + error "todo" + +-- | Find the first element in the list matching the predicate. +-- +-- >>> find even (1 :. 3 :. 5 :. Nil) +-- Empty +-- +-- >>> find even Nil +-- Empty +-- +-- >>> find even (1 :. 2 :. 3 :. 5 :. Nil) +-- Full 2 +-- +-- >>> find even (1 :. 2 :. 3 :. 4 :. 5 :. Nil) +-- Full 2 +-- +-- >>> find (const True) infinity +-- Full 0 +find :: + (a -> Bool) + -> List a + -> Optional a +find = + error "todo" + +-- | Reverse a list. +-- +-- >>> reverse Nil +-- [] +-- +-- prop> let types = x :: List Int in reverse x ++ reverse y == reverse (y ++ x) +-- +-- prop> let types = x :: Int in reverse (x :. Nil) == x :. Nil +reverse :: + List a + -> List a +reverse = + error "todo" + +-- | Do anything other than reverse a list. +-- +-- >>> notReverse Nil +-- [] +-- +-- prop> let types = x :: List Int in notReverse x ++ notReverse y == notReverse (y ++ x) +-- +-- prop> let types = x :: Int in notReverse (x :. Nil) == x :. Nil +notReverse :: + List a + -> List a +notReverse = + error "todo" + +hlist :: + List a + -> [a] +hlist = + foldRight (:) [] + +listh :: + [a] + -> List a +listh = + P.foldr (:.) Nil + +putStr :: + List Char + -> IO () +putStr = + P.putStr . hlist + +putStrLn :: + List Char + -> IO () +putStrLn = + P.putStrLn . hlist + +readFile :: + Filename + -> IO Str +readFile = + P.fmap listh . P.readFile . hlist + +writeFile :: + Filename + -> Str + -> IO () +writeFile n s = + P.writeFile (hlist n) (hlist s) + +getLine :: + IO Str +getLine = + P.fmap listh P.getLine + +isPrefixOf :: + Eq a => + List a + -> List a + -> Bool +isPrefixOf Nil _ = + True +isPrefixOf _ Nil = + False +isPrefixOf (x:.xs) (y:.ys) = + x == y && isPrefixOf xs ys + +isEmpty :: + List a + -> Bool +isEmpty Nil = + True +isEmpty (_:._) = + False + +span :: + (a -> Bool) + -> List a + -> (List a, List a) +span p x = + (takeWhile p x, dropWhile p x) + +break :: + (a -> Bool) + -> List a + -> (List a, List a) +break p = + span (not . p) + +dropWhile :: + (a -> Bool) + -> List a + -> List a +dropWhile _ Nil = + Nil +dropWhile p xs@(x:.xs') = + if p x + then + dropWhile p xs' + else + xs + +takeWhile :: + (a -> Bool) + -> List a + -> List a +takeWhile _ Nil = + Nil +takeWhile p (x:.xs) = + if p x + then + x :. takeWhile p xs + else + Nil + +zip :: + List a + -> List b + -> List (a, b) +zip = + zipWith (,) + +zipWith :: + (a -> b -> c) + -> List a + -> List b + -> List c +zipWith f (a:.as) (b:.bs) = + f a b :. zipWith f as bs +zipWith _ _ _ = + Nil + +unfoldr :: + (a -> Optional (b, a)) + -> a + -> List b +unfoldr f b = + case f b of + Full (a, z) -> a :. unfoldr f z + Empty -> Nil + +lines :: + Str + -> List Str +lines = + listh . P.fmap listh . P.lines . hlist + +unlines :: + List Str + -> Str +unlines = + listh . P.unlines . hlist . map hlist + +words :: + Str + -> List Str +words = + listh . P.fmap listh . P.words . hlist + +unwords :: + List Str + -> Str +unwords = + listh . P.unwords . hlist . map hlist + +listOptional :: + (a -> Optional b) + -> List a + -> List b +listOptional _ Nil = + Nil +listOptional f (h:.t) = + let r = listOptional f t + in case f h of + Empty -> r + Full q -> q :. r + +any :: + (a -> Bool) + -> List a + -> Bool +any p = + foldRight ((||) . p) False + +all :: + (a -> Bool) + -> List a + -> Bool +all p = + foldRight ((&&) . p) True + +or :: + List Bool + -> Bool +or = + any id + +and :: + List Bool + -> Bool +and = + all id + +elem :: + Eq a => + a + -> List a + -> Bool +elem x = + any (== x) + +notElem :: + Eq a => + a + -> List a + -> Bool +notElem x = + all (/= x) + +permutations + :: List a -> List (List a) +permutations xs0 = + let perms Nil _ = + Nil + perms (t:.ts) is = + let interleave' _ Nil r = + (ts, r) + interleave' f (y:.ys) r = + let (us,zs) = interleave' (f . (y:.)) ys r + in (y:.us, f (t:.y:.us):.zs) + in foldRight (\xs -> snd . interleave' id xs) (perms ts (t:.is)) (permutations is) + in xs0 :. perms xs0 Nil + +intersectBy :: + (a -> b -> Bool) + -> List a + -> List b + -> List a +intersectBy e xs ys = + filter (\x -> any (e x) ys) xs + +take :: + (Num n, Ord n) => + n + -> List a + -> List a +take n _ | n <= 0 = + Nil +take _ Nil = + Nil +take n (x:.xs) = + x :. take (n - 1) xs + +drop :: + (Num n, Ord n) => + n + -> List a + -> List a +drop n xs | n <= 0 = + xs +drop _ Nil = + Nil +drop n (_:.xs) = + drop (n-1) xs + +repeat :: + a + -> List a +repeat x = + x :. repeat x + +replicate :: + (Num n, Ord n) => + n + -> a + -> List a +replicate n x = + take n (repeat x) + +reads :: + P.Read a => + Str + -> Optional (a, Str) +reads s = + case P.reads (hlist s) of + [] -> Empty + ((a, q):_) -> Full (a, listh q) + +read :: + P.Read a => + Str + -> Optional a +read = + mapOptional fst . reads + +readHexs :: + (Eq a, Num a) => + Str + -> Optional (a, Str) +readHexs s = + case N.readHex (hlist s) of + [] -> Empty + ((a, q):_) -> Full (a, listh q) + +readHex :: + (Eq a, Num a) => + Str + -> Optional a +readHex = + mapOptional fst . readHexs + +readFloats :: + (RealFrac a) => + Str + -> Optional (a, Str) +readFloats s = + case N.readSigned N.readFloat (hlist s) of + [] -> Empty + ((a, q):_) -> Full (a, listh q) + +readFloat :: + (RealFrac a) => + Str + -> Optional a +readFloat = + mapOptional fst . readFloats + +instance IsString (List Char) where + fromString = + listh + +type Str = + List Char + +type Filename = + Str + +strconcat :: + [Str] + -> P.String +strconcat = + P.concatMap hlist + +stringconcat :: + [P.String] + -> P.String +stringconcat = + P.concat + +instance P.Monad List where + (>>=) = + flip flatMap + return = + (:. Nil) diff --git a/src/Structure/ListZipper.hs b/src/Course/ListZipper.hs similarity index 65% rename from src/Structure/ListZipper.hs rename to src/Course/ListZipper.hs index 379f588..d8fb9de 100644 --- a/src/Structure/ListZipper.hs +++ b/src/Course/ListZipper.hs @@ -1,18 +1,27 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE NoImplicitPrelude #-} -module Structure.ListZipper where +module Course.ListZipper where -import Core -import Data.List -import Monad.Functor +import Course.Core +import Course.List +import Course.Optional +import Course.Functor +import Course.Apply +import Course.Applicative +import Course.Extend +import Course.Comonad +import Course.Traversable +import qualified Prelude as P -- $setup --- >>> import Data.Maybe(isNothing) -- >>> import Test.QuickCheck --- >>> import qualified Prelude as P(return, maybe) --- >>> import Core(Num(..), id, const) --- >>> import Data.List(null) +-- >>> import Data.Maybe(maybe) +-- >>> import Course.Core +-- >>> import qualified Prelude as P +-- >>> let zipper l x r = ListZipper (listh l) x (listh r) +-- >>> let optional e _ Empty = e; optional _ f (Full a) = f a +-- >>> instance Arbitrary a => Arbitrary (Optional a) where arbitrary = P.fmap (maybe Empty Full) arbitrary +-- >>> instance Arbitrary a => Arbitrary (List a) where arbitrary = P.fmap (P.foldr (:.) Nil) arbitrary -- >>> instance Arbitrary a => Arbitrary (ListZipper a) where arbitrary = do l <- arbitrary; x <- arbitrary; r <- arbitrary; P.return (ListZipper l x r) -- A `ListZipper` is a focussed position, with a list of values to the left and to the right. @@ -26,7 +35,7 @@ import Monad.Functor -- then suppose we add 17 to the focus of this zipper: -- ListZipper [1,0] 19 [3,4,5,6] data ListZipper a = - ListZipper [a] a [a] + ListZipper (List a) a (List a) deriving Eq -- A `MaybeListZipper` is a data structure that allows us to "fail" zipper operations. @@ -39,56 +48,48 @@ data MaybeListZipper a = | IsNotZ deriving Eq --- Exercise 1 --- -- | Implement the `Functor` instance for `ListZipper`. -- --- >>> fmap (+1) (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> (+1) <$> (zipper [3,2,1] 4 [5,6,7]) -- [4,3,2] >5< [6,7,8] instance Functor ListZipper where - fmap = + (<$>) = error "todo" --- Exercise 2 --- -- | Implement the `Functor` instance for `MaybeListZipper`. -- --- >>> fmap (+1) (IsZ (ListZipper [3,2,1] 4 [5,6,7])) +-- >>> (+1) <$> (IsZ (zipper [3,2,1] 4 [5,6,7])) -- [4,3,2] >5< [6,7,8] instance Functor MaybeListZipper where - fmap = + (<$>) = error "todo" --- Exercise 3 --- -- | Create a `MaybeListZipper` positioning the focus at the head. -- -- prop> xs == toListZ (fromList xs) fromList :: - [a] + List a -> MaybeListZipper a fromList = error "todo" --- Exercise 4 --- -- | Retrieve the `ListZipper` from the `MaybeListZipper` if there is one. -- --- prop> null xs == isNothing (toMaybe (fromList xs)) +-- prop> isEmpty xs == (toOptional (fromList xs) == Empty) -- --- prop> toMaybe (fromMaybe z) == z -toMaybe :: +-- prop> toOptional (fromOptional z) == z +toOptional :: MaybeListZipper a - -> Maybe (ListZipper a) -toMaybe = + -> Optional (ListZipper a) +toOptional = error "todo" -fromMaybe :: - Maybe (ListZipper a) +fromOptional :: + Optional (ListZipper a) -> MaybeListZipper a -fromMaybe Nothing = +fromOptional Empty = IsNotZ -fromMaybe (Just z) = +fromOptional (Full z) = IsZ z asZipper :: @@ -121,32 +122,28 @@ asMaybeZipper f (IsZ z) = (>->) = asMaybeZipper --- Exercise 5 --- -- | Convert the given zipper back to a list. toList :: ListZipper a - -> [a] + -> List a toList = error "todo" -- | Convert the given (maybe) zipper back to a list. toListZ :: MaybeListZipper a - -> [a] + -> List a toListZ IsNotZ = - [] + Nil toListZ (IsZ z) = toList z --- Exercise 6 --- -- | Update the focus of the zipper with the given function on the current focus. -- --- >>> withFocus (+1) (ListZipper [] 0 [1]) +-- >>> withFocus (+1) (zipper [] 0 [1]) -- [] >1< [1] -- --- >>> withFocus (+1) (ListZipper [1,0] 2 [3,4]) +-- >>> withFocus (+1) (zipper [1,0] 2 [3,4]) -- [1,0] >3< [3,4] withFocus :: (a -> a) @@ -155,15 +152,13 @@ withFocus :: withFocus = error "todo" --- Exercise 7 --- -- | Set the focus of the zipper to the given value. -- /Tip:/ Use `withFocus`. -- --- >>> setFocus 1 (ListZipper [] 0 [1]) +-- >>> setFocus 1 (zipper [] 0 [1]) -- [] >1< [1] -- --- >>> setFocus 1 (ListZipper [1,0] 2 [3,4]) +-- >>> setFocus 1 (zipper [1,0] 2 [3,4]) -- [1,0] >1< [3,4] setFocus :: a @@ -182,14 +177,12 @@ setFocus = (.=) = flip setFocus --- Exercise 8 --- -- | Returns whether there are values to the left of focus. -- --- >>> hasLeft (ListZipper [1,0] 2 [3,4]) +-- >>> hasLeft (zipper [1,0] 2 [3,4]) -- True -- --- >>> hasLeft (ListZipper [] 0 [1,2]) +-- >>> hasLeft (zipper [] 0 [1,2]) -- False hasLeft :: ListZipper a @@ -197,14 +190,12 @@ hasLeft :: hasLeft = error "todo" --- Exercise 9 --- -- | Returns whether there are values to the right of focus. -- --- >>> hasRight (ListZipper [1,0] 2 [3,4]) +-- >>> hasRight (zipper [1,0] 2 [3,4]) -- True -- --- >>> hasRight (ListZipper [1,0] 2 []) +-- >>> hasRight (zipper [1,0] 2 []) -- False hasRight :: ListZipper a @@ -212,14 +203,12 @@ hasRight :: hasRight = error "todo" --- Exercise 10 --- -- | Seek to the left for a location matching a predicate, starting from the -- current one. -- -- prop> findLeft (const True) >-> fromList xs == fromList xs -- --- prop> findLeft (const False) (ListZipper l x r) == IsNotZ +-- prop> findLeft (const False) (zipper l x r) == IsNotZ findLeft :: (a -> Bool) -> ListZipper a @@ -227,14 +216,12 @@ findLeft :: findLeft = error "todo" --- Exercise 11 --- -- | Seek to the right for a location matching a predicate, starting from the -- current one. -- -- prop> findRight (const True) >-> fromList xs == fromList xs -- --- prop> findRight (const False) (ListZipper l x r) == IsNotZ +-- prop> findRight (const False) (zipper l x r) == IsNotZ findRight :: (a -> Bool) -> ListZipper a @@ -242,15 +229,13 @@ findRight :: findRight = error "todo" --- Exercise 12 --- -- | Move the zipper left, or if there are no elements to the left, go to the far right. -- CAUTION: This function is non-total, why? -- --- >>> moveLeftLoop (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveLeftLoop (zipper [3,2,1] 4 [5,6,7]) -- [2,1] >3< [4,5,6,7] -- --- >>> moveLeftLoop (ListZipper [] 1 [2,3,4]) +-- >>> moveLeftLoop (zipper [] 1 [2,3,4]) -- [3,2,1] >4< [] moveLeftLoop :: ListZipper a @@ -258,14 +243,12 @@ moveLeftLoop :: moveLeftLoop = error "todo" --- Exercise 13 --- -- | Move the zipper right, or if there are no elements to the right, go to the far left. -- --- >>> moveRightLoop (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveRightLoop (zipper [3,2,1] 4 [5,6,7]) -- [4,3,2,1] >5< [6,7] -- --- >>> moveRightLoop (ListZipper [3,2,1] 4 []) +-- >>> moveRightLoop (zipper [3,2,1] 4 []) -- [] >1< [2,3,4] moveRightLoop :: ListZipper a @@ -273,14 +256,12 @@ moveRightLoop :: moveRightLoop = error "todo" --- Exercise 14 --- -- | Move the zipper one position to the left. -- --- >>> moveLeft (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveLeft (zipper [3,2,1] 4 [5,6,7]) -- [2,1] >3< [4,5,6,7] -- --- >>> moveLeft (ListZipper [] 1 [2,3,4]) +-- >>> moveLeft (zipper [] 1 [2,3,4]) -- >< moveLeft :: ListZipper a @@ -288,14 +269,12 @@ moveLeft :: moveLeft = error "todo" --- Exercise 15 --- -- | Move the zipper one position to the right. -- --- >>> moveRight (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveRight (zipper [3,2,1] 4 [5,6,7]) -- [4,3,2,1] >5< [6,7] -- --- >>> moveRight (ListZipper [3,2,1] 4 []) +-- >>> moveRight (zipper [3,2,1] 4 []) -- >< moveRight :: ListZipper a @@ -303,14 +282,12 @@ moveRight :: moveRight = error "todo" --- Exercise 16 --- -- | Swap the current focus with the value to the left of focus. -- --- >>> swapLeft (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> swapLeft (zipper [3,2,1] 4 [5,6,7]) -- [4,2,1] >3< [5,6,7] -- --- >>> swapLeft (ListZipper [] 1 [2,3,4]) +-- >>> swapLeft (zipper [] 1 [2,3,4]) -- >< swapLeft :: ListZipper a @@ -318,14 +295,12 @@ swapLeft :: swapLeft = error "todo" --- Exercise 17 --- -- | Swap the current focus with the value to the right of focus. -- --- >>> swapRight (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> swapRight (zipper [3,2,1] 4 [5,6,7]) -- [3,2,1] >5< [4,6,7] -- --- >>> swapRight (ListZipper [3,2,1] 4 []) +-- >>> swapRight (zipper [3,2,1] 4 []) -- >< swapRight :: ListZipper a @@ -333,42 +308,36 @@ swapRight :: swapRight = error "todo" --- Exercise 18 --- -- | Drop all values to the left of the focus. -- --- >>> dropLefts (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> dropLefts (zipper [3,2,1] 4 [5,6,7]) -- [] >4< [5,6,7] -- --- >>> dropLefts (ListZipper [] 1 [2,3,4]) +-- >>> dropLefts (zipper [] 1 [2,3,4]) -- [] >1< [2,3,4] -- --- prop> dropLefts (ListZipper l x r) == ListZipper [] x r +-- prop> dropLefts (zipper l x r) == zipper [] x r dropLefts :: ListZipper a -> ListZipper a dropLefts = error "todo" --- Exercise 19 --- -- | Drop all values to the right of the focus. -- --- >>> dropRights (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> dropRights (zipper [3,2,1] 4 [5,6,7]) -- [3,2,1] >4< [] -- --- >>> dropRights (ListZipper [3,2,1] 4 []) +-- >>> dropRights (zipper [3,2,1] 4 []) -- [3,2,1] >4< [] -- --- prop> dropRights (ListZipper l x r) == ListZipper l x [] +-- prop> dropRights (zipper l x r) == zipper l x [] dropRights :: ListZipper a -> ListZipper a dropRights = error "todo" --- Exercise 20 --- -- Move the focus left the given number of positions. If the value is negative, move right instead. moveLeftN :: Int @@ -377,8 +346,6 @@ moveLeftN :: moveLeftN = error "todo" --- Exercise 21 --- -- Move the focus right the given number of positions. If the value is negative, move left instead. moveRightN :: Int @@ -387,24 +354,22 @@ moveRightN :: moveRightN = error "todo" --- Exercise 22 --- -- | Move the focus left the given number of positions. If the value is negative, move right instead. -- If the focus cannot be moved, the given number of times, return the value by which it can be moved instead. -- --- >>> moveLeftN' 4 (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveLeftN' 4 (zipper [3,2,1] 4 [5,6,7]) -- Left 3 -- --- >>> moveLeftN' 1 (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveLeftN' 1 (zipper [3,2,1] 4 [5,6,7]) -- Right [2,1] >3< [4,5,6,7] -- --- >>> moveLeftN' 0 (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveLeftN' 0 (zipper [3,2,1] 4 [5,6,7]) -- Right [3,2,1] >4< [5,6,7] -- --- >>> moveLeftN' (-2) (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveLeftN' (-2) (zipper [3,2,1] 4 [5,6,7]) -- Right [5,4,3,2,1] >6< [7] -- --- >>> moveLeftN' (-4) (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveLeftN' (-4) (zipper [3,2,1] 4 [5,6,7]) -- Left 3 moveLeftN' :: Int @@ -413,24 +378,22 @@ moveLeftN' :: moveLeftN' = error "todo" --- Exercise 23 --- -- | Move the focus right the given number of positions. If the value is negative, move left instead. -- If the focus cannot be moved, the given number of times, return the value by which it can be moved instead. -- --- >>> moveRightN' 4 (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveRightN' 4 (zipper [3,2,1] 4 [5,6,7]) -- Left 3 -- --- >>> moveRightN' 1 (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveRightN' 1 (zipper [3,2,1] 4 [5,6,7]) -- Right [4,3,2,1] >5< [6,7] -- --- >>> moveRightN' 0 (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveRightN' 0 (zipper [3,2,1] 4 [5,6,7]) -- Right [3,2,1] >4< [5,6,7] -- --- >>> moveRightN' (-2) (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveRightN' (-2) (zipper [3,2,1] 4 [5,6,7]) -- Right [1] >2< [3,4,5,6,7] -- --- >>> moveRightN' (-4) (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> moveRightN' (-4) (zipper [3,2,1] 4 [5,6,7]) -- Left 3 moveRightN' :: Int @@ -439,17 +402,15 @@ moveRightN' :: moveRightN' = error "todo" --- Exercise 24 --- -- | Move the focus to the given absolute position in the zipper. Traverse the zipper only to the extent required. -- --- >>> nth 1 (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> nth 1 (zipper [3,2,1] 4 [5,6,7]) -- [1] >2< [3,4,5,6,7] -- --- >>> nth 5 (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> nth 5 (zipper [3,2,1] 4 [5,6,7]) -- [5,4,3,2,1] >6< [7] -- --- >>> nth 8 (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> nth 8 (zipper [3,2,1] 4 [5,6,7]) -- >< nth :: Int @@ -458,26 +419,22 @@ nth :: nth = error "todo" --- Exercise 25 --- -- | Return the absolute position of the current focus in the zipper. -- --- >>> index (ListZipper [3,2,1] 4 [5,6,7]) --- Just 3 +-- >>> index (zipper [3,2,1] 4 [5,6,7]) +-- Full 3 -- --- prop> P.maybe True (\i -> P.maybe False (==z) (toMaybe (nth i z))) (index z) +-- prop> optional True (\i -> optional False (==z) (toOptional (nth i z))) (index z) index :: ListZipper a - -> Maybe Int + -> Optional Int index = error "todo" --- Exercise 26 --- -- | Move the focus to the end of the zipper. -- CAUTION: This function is non-total, why? -- --- >>> end (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> end (zipper [3,2,1] 4 [5,6,7]) -- [6,5,4,3,2,1] >7< [] end :: ListZipper a @@ -485,11 +442,9 @@ end :: end = error "todo" --- Exercise 27 --- -- | Move the focus to the start of the zipper. -- --- >>> start (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> start (zipper [3,2,1] 4 [5,6,7]) -- [] >1< [2,3,4,5,6,7] start :: ListZipper a @@ -497,14 +452,12 @@ start :: start = error "todo" --- Exercise 28 --- -- | Delete the current focus and pull the left values to take the empty position. -- --- >>> deletePullLeft (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> deletePullLeft (zipper [3,2,1] 4 [5,6,7]) -- [2,1] >3< [5,6,7] -- --- >>> deletePullLeft (ListZipper [] 1 [2,3,4]) +-- >>> deletePullLeft (zipper [] 1 [2,3,4]) -- >< deletePullLeft :: ListZipper a @@ -512,14 +465,12 @@ deletePullLeft :: deletePullLeft = error "todo" --- Exercise 29 --- -- | Delete the current focus and pull the right values to take the empty position. -- --- >>> deletePullRight (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> deletePullRight (zipper [3,2,1] 4 [5,6,7]) -- [3,2,1] >5< [6,7] -- --- >>> deletePullRight (ListZipper [3,2,1] 4 []) +-- >>> deletePullRight (zipper [3,2,1] 4 []) -- >< deletePullRight :: ListZipper a @@ -527,17 +478,15 @@ deletePullRight :: deletePullRight = error "todo" --- Exercise 30 --- -- | Insert at the current focus and push the left values to make way for the new position. -- --- >>> insertPushLeft 15 (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> insertPushLeft 15 (zipper [3,2,1] 4 [5,6,7]) -- [4,3,2,1] >15< [5,6,7] -- --- >>> insertPushLeft 15 (ListZipper [] 1 [2,3,4]) +-- >>> insertPushLeft 15 (zipper [] 1 [2,3,4]) -- [1] >15< [2,3,4] -- --- prop> P.maybe False (==z) (toMaybe (deletePullLeft (insertPushLeft i z))) +-- prop> optional False (==z) (toOptional (deletePullLeft (insertPushLeft i z))) insertPushLeft :: a -> ListZipper a @@ -545,17 +494,15 @@ insertPushLeft :: insertPushLeft = error "todo" --- Exercise 31 --- -- | Insert at the current focus and push the right values to make way for the new position. -- --- >>> insertPushRight 15 (ListZipper [3,2,1] 4 [5,6,7]) +-- >>> insertPushRight 15 (zipper [3,2,1] 4 [5,6,7]) -- [3,2,1] >15< [4,5,6,7] -- --- >>> insertPushRight 15 (ListZipper [3,2,1] 4 []) +-- >>> insertPushRight 15 (zipper [3,2,1] 4 []) -- [3,2,1] >15< [4] -- --- prop> P.maybe False (==z) (toMaybe (deletePullRight (insertPushRight i z))) +-- prop> optional False (==z) (toOptional (deletePullRight (insertPushRight i z))) insertPushRight :: a -> ListZipper a @@ -563,58 +510,15 @@ insertPushRight :: insertPushRight = error "todo" --- Let's start using proper type-class names. --- --- The following type-class hierarchy does not correspond to the GHC base library hierarchy. --- However, it is much more flexible, which we exploit here. - -class Functor f => Apply f where - (<*>) :: - f (a -> b) - -> f a - -> f b - -class Apply f => Applicative f where - unit :: - a -> f a - -class Functor f => Extend f where - (<<=) :: - (f a -> b) - -> f a - -> f b - -class Extend f => Comonad f where - counit :: - f a - -> a - -class Functor t => Traversable t where - traverse :: - Applicative f => - (a -> f b) - -> t a - -> f (t b) - --- The `Traversable` instance for `[]` is implemented for demonstration. --- It will also come in use later. -instance Traversable [] where - traverse f = - foldr (\a b -> fmap (:) (f a) <*> b) (unit []) - --- Exercise 32 --- -- | Implement the `Apply` instance for `ListZipper`. -- This implementation zips functions with values by function application. -- --- >>> ListZipper [(+2), (+10)] (*2) [(*3), (4*), (5+)] <*> ListZipper [3,2,1] 4 [5,6,7] +-- >>> zipper [(+2), (+10)] (*2) [(*3), (4*), (5+)] <*> zipper [3,2,1] 4 [5,6,7] -- [5,12] >8< [15,24,12] instance Apply ListZipper where (<*>) = error "todo" --- Exercise 33 --- -- | Implement the `Apply` instance for `MaybeListZipper`. -- -- /Tip:/ Use `<*>` for `ListZipper`. @@ -622,51 +526,41 @@ instance Apply MaybeListZipper where (<*>) = error "todo" --- Exercise 34 --- -- | Implement the `Applicative` instance for `ListZipper`. -- This implementation produces an infinite list zipper (to both left and right). -- -- /Tip:/ Use @Data.List#repeat@. instance Applicative ListZipper where - unit = + pure = error "todo" --- Exercise 35 --- -- | Implement the `Applicative` instance for `MaybeListZipper`. -- --- /Tip:/ Use @unit@ for `ListZipper`. +-- /Tip:/ Use @pure@ for `ListZipper`. instance Applicative MaybeListZipper where - unit = + pure = error "todo" --- Exercise 36 --- -- | Implement the `Extend` instance for `ListZipper`. -- This implementation "visits" every possible zipper value derivable from a given zipper (i.e. all zippers to the left and right). -- -- /Tip:/ Use @Data.List#unfoldr@. -- --- >>> id <<= (ListZipper [2,1] 3 [4,5]) +-- >>> id <<= (zipper [2,1] 3 [4,5]) -- [[1] >2< [3,4,5],[] >1< [2,3,4,5]] >[2,1] >3< [4,5]< [[3,2,1] >4< [5],[4,3,2,1] >5< []] instance Extend ListZipper where (<<=) = error "todo" --- Exercise 37 --- -- | Implement the `Comonad` instance for `ListZipper`. -- This implementation returns the current focus of the zipper. -- --- >>> counit (ListZipper [2,1] 3 [4,5]) +-- >>> copure (zipper [2,1] 3 [4,5]) -- 3 instance Comonad ListZipper where - counit = + copure = error "todo" --- Exercise 38 --- -- | Implement the `Traversable` instance for `ListZipper`. -- This implementation traverses a zipper while running some `Applicative` effect through the zipper. -- An effectful zipper is returned. @@ -674,8 +568,6 @@ instance Traversable ListZipper where traverse = error "todo" --- Exercise 39 --- -- | Implement the `Traversable` instance for `MaybeListZipper`. -- -- /Tip:/ Use `traverse` for `ListZipper`. @@ -689,7 +581,7 @@ instance Traversable MaybeListZipper where instance Show a => Show (ListZipper a) where show (ListZipper l x r) = - show l ++ " >" ++ show x ++ "< " ++ show r + stringconcat [show l, " >", show x, "< ", show r] instance Show a => Show (MaybeListZipper a) where show (IsZ z) = show z diff --git a/src/Course/Monad.hs b/src/Course/Monad.hs new file mode 100644 index 0000000..a59593a --- /dev/null +++ b/src/Course/Monad.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Monad where + +import Course.Applicative +import Course.Bind +import Course.Core +import Course.Id +import Course.List +import Course.Optional +import qualified Prelude as P + +class (Applicative f, Bind f) => Monad f where + +instance Monad Id where + +instance Monad List where + +instance Monad Optional where + +instance Monad ((->) t) where + +----------------------- +-- SUPPORT LIBRARIES -- +----------------------- + +instance Monad IO where + +instance Monad [] where + +instance Monad P.Maybe where diff --git a/src/Parser/MoreParser.hs b/src/Course/MoreParser.hs similarity index 82% rename from src/Parser/MoreParser.hs rename to src/Course/MoreParser.hs index 48abb59..8ea9230 100644 --- a/src/Parser/MoreParser.hs +++ b/src/Course/MoreParser.hs @@ -1,12 +1,18 @@ -module Parser.MoreParser where +{-# LANGUAGE NoImplicitPrelude #-} -import Parser.Parser -import Data.Char -import Numeric -import Control.Monad +module Course.MoreParser where + +import Course.Core +import Course.Parser +import Course.List +import Course.Optional +import Course.Applicative +import Course.Apply +import Course.Traversable -- $setup --- >>> import Parser.Parser(isErrorResult, character, lower, is) +-- >>> :set -XOverloadedStrings +-- >>> import Course.Parser(isErrorResult, character, lower, is) -- >>> import Data.Char(isUpper, isLower) -- | Parses the given input and returns the result. @@ -14,21 +20,18 @@ import Control.Monad (<.>) :: Parser a -> Input - -> Maybe a + -> Optional a P p <.> i = case p i of - Result _ a -> Just a - _ -> Nothing - + Result _ a -> Full a + _ -> Empty --- Exercise 1 -- | Write a parser that will parse zero or more spaces. spaces :: - Parser String + Parser Str spaces = error "todo" --- Exercise 2 -- | Write a function that applies the given parser, then parses 0 or more spaces, -- then produces the result of the original parser. -- @@ -39,7 +42,6 @@ tok :: tok = error "todo" --- Exercise 3 -- | Write a function that parses the given char followed by 0 or more spaces. -- -- /Tip:/ Use `tok` and `is`. @@ -49,7 +51,6 @@ charTok :: charTok = error "todo" --- Exercise 4 -- | Write a parser that parses a comma ',' followed by 0 or more spaces. -- -- /Tip:/ Use `charTok`. @@ -58,7 +59,6 @@ commaTok :: commaTok = error "todo" --- Exercise 5 -- | Write a parser that parses either a double-quote or a single-quote. -- -- /Tip:/ Use `is` and `|||` @@ -76,7 +76,6 @@ quote :: quote = error "todo" --- Exercise 6 -- | Write a function that parses the given string (fails otherwise). -- -- /Tip:/ Use `is` and `mapM`. @@ -87,12 +86,11 @@ quote = -- >>> isErrorResult (parse (string "abc") "bcdef") -- True string :: - String - -> Parser String + Str + -> Parser Str string = error "todo" --- Exercise 7 -- | Write a function that parsers the given string, followed by 0 or more spaces. -- -- /Tip:/ Use `tok` and `string`. @@ -103,12 +101,11 @@ string = -- >>> isErrorResult (parse (stringTok "abc") "bc ") -- True stringTok :: - String - -> Parser String + Str + -> Parser Str stringTok = error "todo" --- Exercise 8 -- | Write a function that tries the given parser, otherwise succeeds by producing the given value. -- -- /Tip:/ Use `|||`. @@ -125,7 +122,6 @@ option :: option = error "todo" --- Exercise 9 -- | Write a parser that parses 1 or more digits. -- -- /Tip:/ Use `many1` and `digit`. @@ -136,11 +132,10 @@ option = -- >>> isErrorResult (parse digits1 "abc123") -- True digits1 :: - Parser String + Parser Str digits1 = error "todo" --- Exercise 10 -- | Write a function that parses one of the characters in the given string. -- -- /Tip:/ Use `satisfy` and `elem`. @@ -151,12 +146,11 @@ digits1 = -- >>> isErrorResult (parse (oneof "abc") "def") -- True oneof :: - String + Str -> Parser Char oneof = error "todo" --- Exercise 11 -- | Write a function that parses any character, but fails if it is in the given string. -- -- /Tip:/ Use `satisfy` and `notElem`. @@ -167,12 +161,11 @@ oneof = -- >>> isErrorResult (parse (noneof "abcd") "abc") -- True noneof :: - String + Str -> Parser Char noneof = error "todo" --- Exercise 12 -- | Write a function that applies the first parser, runs the third parser keeping the result, -- then runs the second parser and produces the obtained result. -- @@ -197,7 +190,6 @@ between :: between = error "todo" --- Exercise 13 -- | Write a function that applies the given parser in between the two given characters. -- -- /Tip:/ Use `between` and `charTok`. @@ -221,10 +213,9 @@ betweenCharTok :: betweenCharTok = error "todo" --- Exercise 14 -- | Write a function that parses the character 'u' followed by 4 hex digits and return the character value. -- --- /Tip:/ Use `readHex`, `isHexDigit`, `replicateM`, `satisfy` and the monad instance. +-- /Tip:/ Use `readHex`, `isHexDigit`, `replicate`, `satisfy` and the monad instance. -- -- >>> parse hex "u0010" -- Result >< '\DLE' @@ -245,7 +236,6 @@ hex :: hex = error "todo" --- Exercise 15 -- | Write a function that produces a non-empty list of values coming off the given parser (which must succeed at least once), -- separated by the second given parser. -- @@ -265,11 +255,10 @@ hex = sepby1 :: Parser a -> Parser s - -> Parser [a] + -> Parser (List a) sepby1 = error "todo" --- Exercise 16 -- | Write a function that produces a list of values coming off the given parser, -- separated by the second given parser. -- @@ -289,11 +278,10 @@ sepby1 = sepby :: Parser a -> Parser s - -> Parser [a] + -> Parser (List a) sepby = error "todo" --- Exercise 17 -- | Write a parser that asserts that there is no remaining input. -- -- >>> parse eof "" @@ -306,54 +294,51 @@ eof :: eof = error "todo" --- Exercise 18 -- | Write a parser that produces a characer that satisfies all of the given predicates. -- --- /Tip:/ Use `sequence` and @Data.List#and@. +-- /Tip:/ Use `sequenceParser` and @Data.List#and@. -- --- >>> parse (satisfyAll [isUpper, (/= 'X')]) "ABC" +-- >>> parse (satisfyAll (isUpper :. (/= 'X') :. Nil)) "ABC" -- Result >BC< 'A' -- --- >>> parse (satisfyAll [isUpper, (/= 'X')]) "ABc" +-- >>> parse (satisfyAll (isUpper :. (/= 'X') :. Nil)) "ABc" -- Result >Bc< 'A' -- --- >>> isErrorResult (parse (satisfyAll [isUpper, (/= 'X')]) "XBc") +-- >>> isErrorResult (parse (satisfyAll (isUpper :. (/= 'X') :. Nil)) "XBc") -- True -- --- >>> isErrorResult (parse (satisfyAll [isUpper, (/= 'X')]) "") +-- >>> isErrorResult (parse (satisfyAll (isUpper :. (/= 'X') :. Nil)) "") -- True -- --- >>> isErrorResult (parse (satisfyAll [isUpper, (/= 'X')]) "abc") +-- >>> isErrorResult (parse (satisfyAll (isUpper :. (/= 'X') :. Nil)) "abc") -- True satisfyAll :: - [Char -> Bool] + List (Char -> Bool) -> Parser Char satisfyAll = error "todo" --- Exercise 19 -- | Write a parser that produces a characer that satisfies any of the given predicates. -- --- /Tip:/ Use `sequence` and @Data.List#or@. +-- /Tip:/ Use `sequenceParser` and @Data.List#or@. -- --- >>> parse (satisfyAny [isLower, (/= 'X')]) "abc" +-- >>> parse (satisfyAny (isLower :. (/= 'X') :. Nil)) "abc" -- Result >bc< 'a' -- --- >>> parse (satisfyAny [isLower, (/= 'X')]) "ABc" +-- >>> parse (satisfyAny (isLower :. (/= 'X') :. Nil)) "ABc" -- Result >Bc< 'A' -- --- >>> isErrorResult (parse (satisfyAny [isLower, (/= 'X')]) "XBc") +-- >>> isErrorResult (parse (satisfyAny (isLower :. (/= 'X') :. Nil)) "XBc") -- True -- --- >>> isErrorResult (parse (satisfyAny [isLower, (/= 'X')]) "") +-- >>> isErrorResult (parse (satisfyAny (isLower :. (/= 'X') :. Nil)) "") -- True satisfyAny :: - [Char -> Bool] + List (Char -> Bool) -> Parser Char satisfyAny = error "todo" --- Exercise 20 -- | Write a parser that parses between the two given characters, separated by a comma character ','. -- -- /Tip:/ Use `betweenCharTok`, `sepby` and `charTok`. @@ -379,6 +364,6 @@ betweenSepbyComma :: Char -> Char -> Parser a - -> Parser [a] + -> Parser (List a) betweenSepbyComma = error "todo" diff --git a/src/Intro/Optional.hs b/src/Course/Optional.hs similarity index 69% rename from src/Intro/Optional.hs rename to src/Course/Optional.hs index d67d5ff..89383d6 100644 --- a/src/Intro/Optional.hs +++ b/src/Course/Optional.hs @@ -1,4 +1,9 @@ -module Intro.Optional where +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Optional where + +import Course.Core +import qualified Prelude as P -- class Optional { -- Optional(A a) {} // Full @@ -24,3 +29,13 @@ k <+> _ = k twiceOptional :: (a -> b -> c) -> Optional a -> Optional b -> Optional c twiceOptional f a b = bindOptional (\aa -> mapOptional (f aa) b) a + +contains :: Eq a => a -> Optional a -> Bool +contains _ Empty = False +contains a (Full z) = a == z + +instance P.Monad Optional where + (>>=) = + flip bindOptional + return = + Full diff --git a/src/Parser/Parser.hs b/src/Course/Parser.hs similarity index 89% rename from src/Parser/Parser.hs rename to src/Course/Parser.hs index 4b1c794..ea93e9c 100644 --- a/src/Parser/Parser.hs +++ b/src/Course/Parser.hs @@ -1,13 +1,23 @@ -module Parser.Parser where +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} -import Data.Char -import Control.Applicative -import Parser.Person +module Course.Parser where + +import Course.Core +import Course.Person +import Course.Functor +import Course.Apply +import Course.Applicative +import Course.Bind +import Course.Monad +import Course.List +import qualified Prelude as P -- $setup +-- >>> :set -XOverloadedStrings -- >>> import Data.Char(isUpper) -type Input = String +type Input = Str data ParseResult a = UnexpectedEof @@ -21,13 +31,13 @@ instance Show a => Show (ParseResult a) where show UnexpectedEof = "Expected end of stream" show (ExpectedEof i) = - "Expected end of stream, but got >" ++ i ++ "<" + stringconcat ["Expected end of stream, but got >", show i, "<"] show (UnexpectedChar c) = - "Unexpected character" ++ [c] + stringconcat ["Unexpected character", show [c]] show Failed = "Parse failed" show (Result i a) = - "Result >" ++ i ++ "< " ++ show a + stringconcat ["Result >", hlist i, "< ", show a] -- Function to also access the input while binding parsers. withResultInput :: @@ -64,7 +74,6 @@ data Parser a = P { parse :: Input -> ParseResult a } --- Exercise 1 -- | Return a parser that always succeeds with the given value and consumes no input. -- -- >>> parse (valueParser 3) "abc" @@ -75,7 +84,6 @@ valueParser :: valueParser = error "todo" --- Exercise 2 -- | Return a parser that always fails with the given error. -- -- >>> isErrorResult (parse failed "abc") @@ -85,7 +93,6 @@ failed :: failed = error "todo" --- Exercise 3 -- | Return a parser that succeeds with a character off the input or fails with an error if the input is empty. -- -- >>> parse character "abc" @@ -98,7 +105,6 @@ character :: character = error "todo" --- Exercise 4 -- | Return a parser that puts its input into the given parser and -- -- * if that parser succeeds with a value (a), put that value into the given function @@ -129,7 +135,13 @@ bindParser :: bindParser = error "todo" --- Exercise 5 +fbindParser :: + Parser a + -> (a -> Parser b) + -> Parser b +fbindParser = + flip bindParser + -- | Return a parser that puts its input into the given parser and -- -- * if that parser succeeds with a value (a), ignore that value @@ -151,7 +163,6 @@ bindParser = (>>>) = error "todo" --- Exercise 6 -- | Return a parser that tries the first parser for a successful value. -- -- * If the first parser succeeds then use this parser. @@ -178,7 +189,6 @@ bindParser = infixl 3 ||| --- Exercise 7 -- | Return a parser that continues producing a list of values from the given parser. -- -- /Tip:/ Use @many1@, @valueParser@ and @(|||)@. @@ -186,18 +196,17 @@ infixl 3 ||| -- >>> parse (list (character)) "abc" -- Result >< "abc" -- --- >>> parse (list (character >> valueParser 'v')) "abc" +-- >>> parse (list (character *> valueParser 'v')) "abc" -- Result >< "vvv" -- --- >>> parse (list (character >> valueParser 'v')) "" +-- >>> parse (list (character *> valueParser 'v')) "" -- Result >< "" list :: Parser a - -> Parser [a] + -> Parser (List a) list = error "todo" --- Exercise 8 -- | Return a parser that produces at least one value from the given parser then -- continues producing a list of values from the given parser (to ultimately produce a non-empty list). -- The returned parser fails if The input is empty. @@ -207,18 +216,17 @@ list = -- >>> parse (many1 (character)) "abc" -- Result >< "abc" -- --- >>> parse (many1 (character >> valueParser 'v')) "abc" +-- >>> parse (many1 (character *> valueParser 'v')) "abc" -- Result >< "vvv" -- --- >>> isErrorResult (parse (many1 (character >> valueParser 'v')) "") +-- >>> isErrorResult (parse (many1 (character *> valueParser 'v')) "") -- True many1 :: Parser a - -> Parser [a] + -> Parser (List a) many1 = error "todo" --- Exercise 9 -- | Return a parser that produces a character but fails if -- -- * The input is empty. @@ -238,7 +246,6 @@ satisfy :: satisfy = error "todo" --- Exercise 10.1 -- | Return a parser that produces the given character but fails if -- -- * The input is empty. @@ -247,12 +254,10 @@ satisfy = -- -- /Tip:/ Use the @satisfy@ function. is :: - Char - -> Parser Char + Char -> Parser Char is = error "todo" --- Exercise 10.2 -- | Return a parser that produces a character between '0' and '9' but fails if -- -- * The input is empty. @@ -265,7 +270,6 @@ digit :: digit = error "todo" --- Exercise 10.3 -- | Return a parser that produces zero or a positive integer but fails if -- -- * The input is empty. @@ -279,7 +283,6 @@ natural :: natural = error "todo" --- Exercise 10.4 -- -- | Return a parser that produces a space character but fails if -- @@ -293,7 +296,6 @@ space :: space = error "todo" --- Exercise 10.5 -- | Return a parser that produces one or more space characters -- (consuming until the first non-space) but fails if -- @@ -303,11 +305,10 @@ space = -- -- /Tip:/ Use the @many1@ and @space@ functions. spaces1 :: - Parser String + Parser Str spaces1 = error "todo" --- Exercise 10.6 -- | Return a parser that produces a lower-case character but fails if -- -- * The input is empty. @@ -320,7 +321,6 @@ lower :: lower = error "todo" --- Exercise 10.7 -- | Return a parser that produces an upper-case character but fails if -- -- * The input is empty. @@ -333,7 +333,6 @@ upper :: upper = error "todo" --- Exercise 10.8 -- | Return a parser that produces an alpha character but fails if -- -- * The input is empty. @@ -346,25 +345,23 @@ alpha :: alpha = error "todo" --- Exercise 11 -- | Return a parser that sequences the given list of parsers by producing all their results -- but fails on the first failing parser of the list. -- -- /Tip:/ Use @bindParser@ and @value@. -- /Tip:/ Optionally use @Prelude.foldr@. If not, an explicit recursive call. -- --- >>> parse (sequenceParser [character, is 'x', upper]) "axCdef" +-- >>> parse (sequenceParser (character :. is 'x' :. upper :. Nil)) "axCdef" -- Result >def< "axC" -- --- >>> isErrorResult (parse (sequenceParser [character, is 'x', upper]) "abCdef") +-- >>> isErrorResult (parse (sequenceParser (character :. is 'x' :. upper :. Nil)) "abCdef") -- True sequenceParser :: - [Parser a] - -> Parser [a] + List (Parser a) + -> Parser (List a) sequenceParser = error "todo" --- Exercise 12 -- | Return a parser that produces the given number of values off the given parser. -- This parser fails if the given parser fails in the attempt to produce the given number of values. -- @@ -378,11 +375,10 @@ sequenceParser = thisMany :: Int -> Parser a - -> Parser [a] + -> Parser (List a) thisMany = error "todo" --- Exercise 13 -- | Write a parser for Person.age. -- -- /Age: positive integer/ @@ -402,7 +398,6 @@ ageParser :: ageParser = error "todo" --- Exercise 14 -- | Write a parser for Person.firstName. -- /First Name: non-empty string that starts with a capital letter/ -- @@ -414,11 +409,10 @@ ageParser = -- λ> isErrorResult (parse firstNameParser "abc") -- True firstNameParser :: - Parser String + Parser Str firstNameParser = error "todo" --- Exercise 15 -- | Write a parser for Person.surname. -- -- /Surname: string that starts with a capital letter and is followed by 5 or more lower-case letters./ @@ -434,11 +428,10 @@ firstNameParser = -- >>> isErrorResult (parse surnameParser "abc") -- True surnameParser :: - Parser String + Parser Str surnameParser = error "todo" --- Exercise 16 -- | Write a parser for Person.gender. -- -- /Gender: character that must be @'m'@ or @'f'@/ @@ -458,7 +451,6 @@ genderParser :: genderParser = error "todo" --- Exercise 17 -- | Write part of a parser for Person.phoneBody. -- This parser will only produce a string of digits, dots or hyphens. -- It will ignore the overall requirement of a phone number to @@ -477,11 +469,10 @@ genderParser = -- >>> parse phoneBodyParser "a123-456" -- Result >a123-456< "" phoneBodyParser :: - Parser String + Parser Str phoneBodyParser = error "todo" --- Exercise 18 -- | Write a parser for Person.phone. -- -- /Phone: ... but must start with a digit and end with a hash (#)./ @@ -500,11 +491,10 @@ phoneBodyParser = -- >>> isErrorResult (parse phoneParser "a123-456") -- True phoneParser :: - Parser String + Parser Str phoneParser = error "todo" --- Exercise 19 -- | Write a parser for Person. -- -- /Tip:/ Use @bindParser@, @@ -553,31 +543,35 @@ personParser :: personParser = error "todo" --- Exercise 20 -- Make sure all the tests pass! --- Exercise 20.1 -- | Write a Functor instance for a @Parser@. -- /Tip:/ Use @bindParser@ and @valueParser@. instance Functor Parser where - fmap = + (<$>) = + error "todo" + +-- | Write a Apply instance for a @Parser@. +-- /Tip:/ Use @bindParser@ and @valueParser@. +instance Apply Parser where + (<*>) = error "todo" --- Exercise 20.2 -- | Write an Applicative functor instance for a @Parser@. --- --- /Tip:/ Use @bindParser@ and @valueParser@. instance Applicative Parser where pure = error "todo" - (<*>) = + +-- | Write a Bind instance for a @Parser@. +instance Bind Parser where + (=<<) = error "todo" --- Exercise 20.3 --- | Write a Monad instance for a @Parser@. instance Monad Parser where - return = - error "todo" + +instance P.Monad Parser where (>>=) = - error "todo" + flip (=<<) + return = + pure diff --git a/src/Parser/Person.hs b/src/Course/Person.hs similarity index 77% rename from src/Parser/Person.hs rename to src/Course/Person.hs index 0ddee5d..6c7dba8 100644 --- a/src/Parser/Person.hs +++ b/src/Course/Person.hs @@ -1,4 +1,9 @@ -module Parser.Person where +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Person where + +import Course.Core +import Course.List -- Suppose we have a data structure to represent a person. The person data structure has these attributes: -- * Age: positive integer @@ -8,9 +13,9 @@ module Parser.Person where -- * Phone: string of digits, dots or hyphens but must start with a digit and end with a hash (#) data Person = Person { age :: Int, - firstName :: String, - surname :: String, + firstName :: Str, + surname :: Str, gender :: Char, - phone :: String + phone :: Str } deriving (Eq, Show) diff --git a/src/Monad/State.hs b/src/Course/State.hs similarity index 69% rename from src/Monad/State.hs rename to src/Course/State.hs index 04f6185..7c062af 100644 --- a/src/Monad/State.hs +++ b/src/Course/State.hs @@ -1,16 +1,16 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE NoImplicitPrelude #-} -module Monad.State where +module Course.State where -import Core +import Course.Core import qualified Prelude as P -import Data.Char -import Intro.Optional -import Structure.List -import Monad.Functor -import Monad.Monad -import qualified Data.Foldable as F +import Course.Optional +import Course.List +import Course.Functor +import Course.Apply +import Course.Applicative +import Course.Bind +import Course.Monad import qualified Data.Set as S -- $setup @@ -18,9 +18,9 @@ import qualified Data.Set as S -- >>> import Data.List(nub) -- >>> import Test.QuickCheck -- >>> import qualified Prelude as P(fmap) --- >>> import Core(Integral(..), Num(..), Eq(..), foldr, const, ($), fst, snd) --- >>> import Structure.List(flatMap, len, filter, foldRight) --- >>> instance Arbitrary a => Arbitrary (List a) where arbitrary = P.fmap (foldr (:.) Nil) arbitrary +-- >>> import Course.Core +-- >>> import Course.List +-- >>> instance Arbitrary a => Arbitrary (List a) where arbitrary = P.fmap listh arbitrary -- A `State` is a function from a state value `s` to (a produced value `a`, and a resulting state `s`). newtype State s a = @@ -30,36 +30,32 @@ newtype State s a = -> (a, s) } --- Exercise 1 --- Relative Difficulty: 2 --- -- | Implement the `Functor` instance for `State s`. --- --- >>> runState (fmap (+1) (return 0)) 0 +-- >>> runState ((+1) <$> pure 0) 0 -- (1,0) instance Functor (State s) where - fmap = + (<$>) = error "todo" --- Exercise 2 --- Relative Difficulty: 3 --- --- | Implement the `Monad` instance for `State s`. --- Make sure the state value is passed through in `bind`. --- --- >>> runState (return 1) 0 --- (1,0) --- --- >>> runState (bind (const $ put 2) (put 1)) 0 --- ((),2) -instance Monad (State s) where - bind = +-- | Implement the `Apply` instance for `State s`. +instance Apply (State s) where + (<*>) = + error "todo" + +-- | Implement the `Applicative` instance for `State s`. +instance Applicative (State s) where + pure = error "todo" - return = + +-- | Implement the `Bind` instance for `State s`. +-- >>> runState ((const $ put 2) =<< put 1) 0 +-- ((),2) +instance Bind (State s) where + (=<<) = error "todo" --- Exercise 3 --- Relative Difficulty: 1 +instance Monad (State s) where + -- | Run the `State` seeded with `s` and retrieve the resulting state. -- -- prop> \(Fun _ f) -> exec (State f) s == snd (runState (State f) s) @@ -70,9 +66,6 @@ exec :: exec = error "todo" --- Exercise 4 --- Relative Difficulty: 1 --- -- | Run the `State` seeded with `s` and retrieve the resulting value. -- -- prop> \(Fun _ f) -> eval (State f) s == fst (runState (State f) s) @@ -83,9 +76,6 @@ eval :: eval = error "todo" --- Exercise 5 --- Relative Difficulty: 2 --- -- | A `State` where the state also distributes into the produced value. -- -- >>> runState get 0 @@ -95,9 +85,6 @@ get :: get = error "todo" --- Exercise 6 --- Relative Difficulty: 2 --- -- | A `State` where the resulting state is seeded with the given value. -- -- >>> runState (put 1) 0 @@ -108,9 +95,6 @@ put :: put = error "todo" --- Exercise 7 --- Relative Difficulty: 5 --- -- | Find the first element in a `List` that satisfies a given predicate. -- It is possible that no element is found, hence an `Optional` result. -- However, while performing the search, we sequence some `Monad` effect through. @@ -120,10 +104,10 @@ put = -- find :: (a -> Bool) -> List a -> Optional a -- findM :: (a -> f Bool) -> List a -> f (Optional a) -- --- >>> let p x = bind (\s -> bind (const $ return (x == 'c')) $ put (1+s)) get in runState (findM p $ foldr (:.) Nil ['a'..'h']) 0 +-- >>> let p x = (\s -> (const $ pure (x == 'c')) =<< put (1+s)) =<< get in runState (findM p $ listh ['a'..'h']) 0 -- (Full 'c',3) -- --- >>> let p x = bind (\s -> bind (const $ return (x == 'i')) $ put (1+s)) get in runState (findM p $ foldr (:.) Nil ['a'..'h']) 0 +-- >>> let p x = (\s -> (const $ pure (x == 'i')) =<< put (1+s)) =<< get in runState (findM p $ listh ['a'..'h']) 0 -- (Empty,8) findM :: Monad f => @@ -133,15 +117,12 @@ findM :: findM = error "todo" --- Exercise 8 --- Relative Difficulty: 4 --- -- | Find the first element in a `List` that repeats. -- It is possible that no element repeats, hence an `Optional` result. -- -- /Tip:/ Use `findM` and `State` with a @Data.Set#Set@. -- --- prop> case firstRepeat xs of Empty -> let xs' = foldRight (:) [] xs in nub xs' == xs'; Full x -> len (filter (== x) xs) > 1 +-- prop> case firstRepeat xs of Empty -> let xs' = foldRight (:) [] xs in nub xs' == xs'; Full x -> length (filter (== x) xs) > 1 firstRepeat :: Ord a => List a @@ -149,9 +130,6 @@ firstRepeat :: firstRepeat = error "todo" --- Exercise 9 --- Relative Difficulty: 5 --- -- | Remove all elements in a `List` that fail a given predicate. -- However, while performing the filter, we sequence some `Monad` effect through. -- @@ -160,10 +138,10 @@ firstRepeat = -- filter :: (a -> Bool) -> List a -> List a -- filterM :: (a -> f Bool) -> List a -> f (List a) -- --- >>> let p x = Full (x `mod` 2 == 0); xs = foldr (:.) Nil [1..10] in filterM p xs +-- >>> let p x = Full (x `mod` 2 == 0); xs = listh [1..10] in filterM p xs -- Full [2,4,6,8,10] -- --- >>> let p x = if x `mod` 2 == 0 then Full True else Empty; xs = foldr (:.) Nil [1..10] in filterM p xs +-- >>> let p x = if x `mod` 2 == 0 then Full True else Empty; xs = listh [1..10] in filterM p xs -- Empty filterM :: Monad f => @@ -173,9 +151,6 @@ filterM :: filterM = error "todo" --- Exercise 10 --- Relative Difficulty: 4 --- -- | Remove all duplicate elements in a `List`. -- /Tip:/ Use `filterM` and `State` with a @Data.Set#Set@. -- @@ -189,9 +164,6 @@ distinct :: distinct = error "todo" --- Exercise 11 --- Relative Difficulty: 3 --- -- | Produce an infinite `List` that seeds with the given value at its head, -- then runs the given function for subsequent elements -- @@ -207,15 +179,13 @@ produce :: produce = error "todo" --- Exercise 12 --- Relative Difficulty: 10 -- | A happy number is a positive integer, where the sum of the square of its digits eventually reaches 1 after repetition. -- In contrast, a sad number (not a happy number) is where the sum of the square of its digits never reaches 1 -- because it results in a recurring sequence. -- -- /Tip:/ Use `findM` with `State` and `produce`. -- --- /Tip:/ Use `flaatten` to write a @square@ function. +-- /Tip:/ Use `flatten` to write a @square@ function. -- -- /Tip:/ Use library functions: @Data.Foldable#elem@, @Data.Char#digitToInt@. -- @@ -235,11 +205,3 @@ isHappy :: -> Bool isHappy = error "todo" - ------------------------ --- SUPPORT LIBRARIES -- ------------------------ - -instance F.Foldable Optional where - foldr _ z Empty = z - foldr f z (Full a) = f a z diff --git a/src/Monad/StateT.hs b/src/Course/StateT.hs similarity index 70% rename from src/Monad/StateT.hs rename to src/Course/StateT.hs index 8365f6e..76e9f3a 100644 --- a/src/Monad/StateT.hs +++ b/src/Course/StateT.hs @@ -1,15 +1,20 @@ {-# LANGUAGE NoImplicitPrelude #-} - -module Monad.StateT where - -import Core -import Intro.Id -import Intro.Optional -import Structure.List -import Monad.Functor -import Monad.Monad -import Monad.State +{-# LANGUAGE OverloadedStrings #-} + +module Course.StateT where + +import Course.Core +import Course.Id +import Course.Optional +import Course.List +import Course.Functor +import Course.Apply +import Course.Applicative +import Course.Bind +import Course.Monad +import Course.State import qualified Data.Set as S +import qualified Prelude as P -- | A `StateT` is a function from a state value `s` to a functor f of (a produced value `a`, and a resulting state `s`). newtype StateT s f a = @@ -19,29 +24,33 @@ newtype StateT s f a = -> f (a, s) } --- Exercise 1 --- Relative Difficulty: 2 -- | Implement the `Functor` instance for @StateT s f@ given a @Functor f@. instance Functor f => Functor (StateT s f) where - fmap = + (<$>) = error "todo" --- Exercise 2 --- Relative Difficulty: 5 --- | Implement the `Monad` instance for @StateT s g@ given a @Monad f@. --- Make sure the state value is passed through in `bind`. -instance Monad f => Monad (StateT s f) where - bind = +-- | Implement the `Apply` instance for @StateT s f@ given a @Applicative f@. +instance Bind f => Apply (StateT s f) where + (<*>) = + error "todo" + +-- | Implement the `Applicative` instance for @StateT s f@ given a @Applicative f@. +instance Monad f => Applicative (StateT s f) where + pure = error "todo" - return = + +-- | Implement the `Bind` instance for @StateT s f@ given a @Monad f@. +-- Make sure the state value is passed through in `bind`. +instance Monad f => Bind (StateT s f) where + (=<<) = error "todo" +instance Monad f => Monad (StateT s f) where + -- | A `State'` is `StateT` specialised to the `Id` functor. type State' s a = StateT s Id a --- Exercise 3 --- Relative Difficulty: 1 -- | Provide a constructor for `State'` values. state' :: (s -> (a, s)) @@ -49,8 +58,6 @@ state' :: state' = error "todo" --- Exercise 4 --- Relative Difficulty: 1 -- | Provide an unwrapper for `State'` values. runState' :: State' s a @@ -59,8 +66,6 @@ runState' :: runState' = error "todo" --- Exercise 5 --- Relative Difficulty: 2 -- | Run the `StateT` seeded with `s` and retrieve the resulting state. execT :: Functor f => @@ -70,8 +75,6 @@ execT :: execT = error "todo" --- Exercise 6 --- Relative Difficulty: 1 -- | Run the `State` seeded with `s` and retrieve the resulting state. exec' :: State' s a @@ -80,8 +83,6 @@ exec' :: exec' = error "todo" --- Exercise 7 --- Relative Difficulty: 2 -- | Run the `StateT` seeded with `s` and retrieve the resulting value. evalT :: Functor f => @@ -91,8 +92,6 @@ evalT :: evalT = error "todo" --- Exercise 8 --- Relative Difficulty: 1 -- | Run the `State` seeded with `s` and retrieve the resulting value. eval' :: State' s a @@ -101,8 +100,6 @@ eval' :: eval' = error "todo" --- Exercise 9 --- Relative Difficulty: 2 -- | A `StateT` where the state also distributes into the produced value. getT :: Monad f => @@ -110,8 +107,6 @@ getT :: getT = error "todo" --- Exercise 10 --- Relative Difficulty: 2 -- | A `StateT` where the resulting state is seeded with the given value. putT :: Monad f => @@ -120,8 +115,6 @@ putT :: putT = error "todo" --- Exercise 11 --- Relative Difficulty: 4 -- | Remove all duplicate elements in a `List`. -- -- /Tip:/ Use `filterM` and `State'` with a @Data.Set#Set@. @@ -132,8 +125,6 @@ distinct' :: distinct' = error "todo" --- Exercise 12 --- Relative Difficulty: 5 -- | Remove all duplicate elements in a `List`. -- However, if you see a value greater than `100` in the list, -- abort the computation by producing `Empty`. @@ -153,46 +144,56 @@ data OptionalT f a = f (Optional a) } --- Exercise 13 --- Relative Difficulty: 3 -- | Implement the `Functor` instance for `OptionalT f` given a Functor f. instance Functor f => Functor (OptionalT f) where - fmap = + (<$>) = error "todo" --- Exercise 14 --- Relative Difficulty: 5 --- | Implement the `Monad` instance for `OptionalT f` given a Monad f. -instance Monad f => Monad (OptionalT f) where - return = +-- | Implement the `Apply` instance for `OptionalT f` given a Apply f. +instance Apply f => Apply (OptionalT f) where + (<*>) = + error "todo" + +-- | Implement the `Applicative` instance for `OptionalT f` given a Applicative f. +instance Applicative f => Applicative (OptionalT f) where + pure = error "todo" - bind = + +-- | Implement the `Bind` instance for `OptionalT f` given a Bind f. +instance Bind f => Bind (OptionalT f) where + (=<<) = error "todo" +instance Monad f => Monad (OptionalT f) where + -- | A `Logger` is a pair of a list of log values (`[l]`) and an arbitrary value (`a`). data Logger l a = - Logger [l] a + Logger (List l) a deriving (Eq, Show) --- Exercise 15 --- Relative Difficulty: 4 -- | Implement the `Functor` instance for `Logger`. instance Functor (Logger l) where - fmap = + (<$>) = error "todo" --- Exercise 16 --- Relative Difficulty: 5 --- | Implement the `Monad` instance for `Logger`. --- The `bind` implementation must append log values to maintain associativity. -instance Monad (Logger l) where - return = +-- | Implement the `Apply` instance for `Logger`. +instance Apply (Logger l) where + (<*>) = error "todo" - bind = + +-- | Implement the `Applicative` instance for `Logger`. +instance Applicative (Logger l) where + pure = + error "todo" + +-- | Implement the `Bind` instance for `Logger`. +-- The `bind` implementation must append log values to maintain associativity. +instance Bind (Logger l) where + (=<<) = error "todo" --- Exercise 17 --- Relative Difficulty: 1 +instance Monad (Logger l) where + -- | A utility function for producing a `Logger` with one log value. log1 :: l @@ -201,8 +202,6 @@ log1 :: log1 = error "todo" --- Exercise 18 --- Relative Difficulty: 10 -- | Remove all duplicate integers from a list. Produce a log as you go. -- If there is an element above 100, then abort the entire computation and produce no result. -- However, always keep a log. If you abort the computation, produce a log with the value, @@ -214,6 +213,6 @@ log1 = distinctG :: (Integral a, Show a) => List a - -> Logger String (Optional (List a)) + -> Logger Str (Optional (List a)) distinctG = error "todo" diff --git a/src/Course/Traversable.hs b/src/Course/Traversable.hs new file mode 100644 index 0000000..e4174d7 --- /dev/null +++ b/src/Course/Traversable.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Traversable where + +import Course.Functor +import Course.Apply +import Course.Applicative +import Course.List + +class Functor t => Traversable t where + traverse :: + Applicative f => + (a -> f b) + -> t a + -> f (t b) + +instance Traversable List where + traverse f = + foldRight (\a b -> (:.) <$> (f a) <*> b) (pure Nil) diff --git a/src/Intro/Validation.hs b/src/Course/Validation.hs similarity index 91% rename from src/Intro/Validation.hs rename to src/Course/Validation.hs index 9fd5129..ca8e685 100644 --- a/src/Intro/Validation.hs +++ b/src/Course/Validation.hs @@ -1,4 +1,8 @@ -module Intro.Validation where +{-# LANGUAGE NoImplicitPrelude #-} + +module Course.Validation where + +import Course.Core -- class Validation { -- Validation(String error) {} // Error @@ -7,11 +11,12 @@ module Intro.Validation where -- $setup -- >>> import Test.QuickCheck --- >>> instance Arbitrary a => Arbitrary (Validation a) where arbitrary = fmap (either Error Value) arbitrary +-- >>> import qualified Prelude as P(fmap, either) +-- >>> instance Arbitrary a => Arbitrary (Validation a) where arbitrary = P.fmap (P.either Error Value) arbitrary data Validation a = Error Err | Value a deriving (Eq, Show) -type Err = String +type Err = [Char] -- | Returns whether or not the given validation is an error. -- diff --git a/src/Monad/Compose.hs b/src/Monad/Compose.hs deleted file mode 100644 index 0cbf1cc..0000000 --- a/src/Monad/Compose.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Monad.Compose where - -import Control.Applicative - --- Exactly one of these exercises will not be possible to achieve. Determine which. - -newtype Compose f g a = - Compose (f (g a)) - --- Exercise 1 --- Implement a Functor instance for Compose -instance (Functor f, Functor g) => - Functor (Compose f g) where - fmap = - error "todo" - -instance (Applicative f, Applicative g) => - Applicative (Compose f g) where --- Exercise 2 --- Implement the pure function for an Applicative instance for Compose - pure = - error "todo" --- Exercise 3 --- Implement the (<*>) function for an Applicative instance for Compose - (<*>) = - error "todo" - -instance (Monad f, Monad g) => - Monad (Compose f g) where --- Exercise 4 --- Implement the return function for a Monad instance for Compose - return = - error "todo" --- Exercise 5 --- Implement the (>>=) function for a Monad instance for Compose - (>>=) = - error "todo" diff --git a/src/Monad/Functor.hs b/src/Monad/Functor.hs deleted file mode 100644 index 09bb5e4..0000000 --- a/src/Monad/Functor.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Monad.Functor where - -import Core -import qualified Prelude as P -import Intro.Id -import Intro.Optional -import Structure.List - -class Functor f where - fmap :: (a -> b) -> f a -> f b - --- $setup --- >>> import Core(Num(..), putStr, reverse, (>>)) --- >>> import qualified Prelude as P(return) - --- Exercise 1 --- Relative Difficulty: 1 --- --- | Maps a function on the Id functor. --- --- >>> fmap (+1) (Id 2) --- Id 3 -instance Functor Id where - fmap = - error "todo" - --- Exercise 2 --- Relative Difficulty: 2 --- --- | Maps a function on the List functor. --- --- >>> fmap (+1) Nil --- [] --- --- >>> fmap (+1) (1 :. 2 :. 3 :. Nil) --- [2,3,4] -instance Functor List where - fmap = - error "todo" - --- Exercise 3 --- Relative Difficulty: 2 --- --- | Maps a function on the Optional functor. --- --- >>> fmap (+1) Empty --- Empty --- --- >>> fmap (+1) (Full 2) --- Full 3 -instance Functor Optional where - fmap = - error "todo" - --- Exercise 4 --- Relative Difficulty: 3 --- --- | Maps a function on the reader ((->) t) functor. --- --- >>> fmap (+1) (*2) 8 --- 17 -instance Functor ((->) t) where - fmap = - error "todo" - ------------------------ --- SUPPORT LIBRARIES -- ------------------------ - --- | Maps a function on an IO program. --- --- >>> fmap reverse (putStr "hi" >> P.return "abc") --- hi"cba" -instance Functor IO where - fmap = - P.fmap - -instance Functor [] where - fmap = - P.fmap - -instance Functor Maybe where - fmap = - P.fmap diff --git a/src/Monad/Monad.hs b/src/Monad/Monad.hs deleted file mode 100644 index 91aee50..0000000 --- a/src/Monad/Monad.hs +++ /dev/null @@ -1,385 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Monad.Monad where - -import Core -import qualified Prelude as P -import Intro.Id -import Intro.Optional -import Structure.List - --- $setup --- >>> import Core(Eq(..), Num(..), Ord(..), even, (.)) --- >>> import Structure.List(product, sum, len, filter, listh) - -class Monad m where - bind :: - (a -> m b) - -> m a - -> m b - return :: - a - -> m a - -- Exercise 6 - -- Relative Difficulty: 3 - -- (use bind and return) - -- - -- | Witness that all things with bind and return also have fmap. - -- - -- >>> fmap' (+1) (Id 2) - -- Id 3 - -- - -- >>> fmap' (+1) Nil - -- [] - -- - -- >>> fmap' (+1) (1 :. 2 :. 3 :. Nil) - -- [2,3,4] - fmap' :: - (a -> b) - -> m a - -> m b - fmap' = - error "todo" - --- Exercise 7 --- Relative Difficulty: 1 --- --- | Binds a function on the Id monad. --- --- >>> bind (\x -> Id(x+1)) (Id 2) --- Id 3 --- --- prop> return x == Id x -instance Monad Id where - bind = - error "todo" - return = - error "todo" - --- Exercise 8 --- Relative Difficulty: 2 --- --- | Binds a function on the List monad. --- --- >>> bind (\n -> n :. n :. Nil) (1 :. 2 :. 3 :. Nil) --- [1,1,2,2,3,3] --- --- prop> return x == x :. Nil -instance Monad List where - bind = - error "todo" - return = - error "todo" - --- Exercise 9 --- Relative Difficulty: 2 --- --- | Binds a function on the Optional monad. --- --- >>> bind (\n -> Full (n + n)) (Full 7) --- Full 14 --- --- prop> return x == Full x -instance Monad Optional where - bind = - error "todo" - return = - error "todo" - --- Exercise 10 --- Relative Difficulty: 3 --- --- | Binds a function on the reader ((->) t) monad. --- --- >>> bind (*) (+10) 7 --- 119 --- --- prop> return x y == x -instance Monad ((->) t) where - bind = - error "todo" - return = - error "todo" - --- Exercise 11 --- Relative Difficulty: 2 --- --- | Flattens a combined structure to a single structure. --- --- >>> flatten' ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) --- [1,2,3,1,2] --- --- >>> flatten' (Full Empty) --- Empty --- --- >>> flatten' (Full (Full 7)) --- Full 7 --- --- >>> flatten' (+) 7 --- 14 -flatten' :: - Monad m => - m (m a) - -> m a -flatten' = - error "todo" - --- Exercise 12 --- Relative Difficulty: 10 --- --- | Applies a structure on functions to a structure on values. --- --- >>> apply (Id (+1)) (Id 2) --- Id 3 --- --- >>> apply ((+1) :. (*2) :. Nil) (4 :. 5 :. 6 :. Nil) --- [5,6,7,8,10,12] --- --- >>> apply (Full (+1)) (Full 2) --- Full 3 --- --- >>> apply (Full (+1)) Empty --- Empty --- --- >>> apply Empty (Full 2) --- Empty --- --- >>> apply Empty Empty --- Empty --- --- >>> apply (*) (+10) 6 --- 96 -apply :: - Monad m => - m (a -> b) - -> m a - -> m b -apply = - error "todo" - --- Exercise 13 --- Relative Difficulty: 6 --- (bonus: use apply + fmap') --- --- | Apply a binary function in the Monad environment. --- --- >>> lift2 (+) (Id 7) (Id 8) --- Id 15 --- --- >>> lift2 (+) (1 :. 2 :. 3 :. Nil) (4 :. 5 :. Nil) --- [5,6,6,7,7,8] --- --- >>> lift2 (+) (Full 7) (Full 8) --- Full 15 --- --- >>> lift2 (+) (Full 7) Empty --- Empty --- --- >>> lift2 (+) Empty (Full 8) --- Empty --- --- >>> lift2 (+) len sum (listh [4,5,6]) --- 18 -lift2 :: - Monad m => - (a -> b -> c) - -> m a - -> m b - -> m c -lift2 = - error "todo" - --- Exercise 14 --- Relative Difficulty: 6 --- (bonus: use apply + lift2) --- --- | Apply a ternary function in the Monad environment. --- --- >>> lift3 (\a b c -> a + b + c) (Id 7) (Id 8) (Id 9) --- Id 24 --- --- >>> lift3 (\a b c -> a + b + c) (1 :. 2 :. 3 :. Nil) (4 :. 5 :. Nil) (6 :. 7 :. 8 :. Nil) --- [11,12,13,12,13,14,12,13,14,13,14,15,13,14,15,14,15,16] --- --- >>> lift3 (\a b c -> a + b + c) (Full 7) (Full 8) (Full 9) --- Full 24 --- --- >>> lift3 (\a b c -> a + b + c) (Full 7) (Full 8) Empty --- Empty --- --- >>> lift3 (\a b c -> a + b + c) Empty (Full 8) (Full 9) --- Empty --- --- >>> lift3 (\a b c -> a + b + c) Empty Empty (Full 9) --- Empty --- --- >>> lift3 (\a b c -> a + b + c) len sum product (listh [4,5,6]) --- 138 -lift3 :: - Monad m => - (a -> b -> c -> d) - -> m a - -> m b - -> m c - -> m d -lift3 = - error "todo" - --- Exercise 15 --- Relative Difficulty: 6 --- (bonus: use apply + lift3) --- --- | Apply a quaternary function in the Monad environment. --- --- >>> lift4 (\a b c d -> a + b + c + d) (Id 7) (Id 8) (Id 9) (Id 10) --- Id 34 --- --- >>> lift4 (\a b c d -> a + b + c + d) (1 :. 2 :. 3 :. Nil) (4 :. 5 :. Nil) (6 :. 7 :. 8 :. Nil) (9 :. 10 :. Nil) --- [20,21,21,22,22,23,21,22,22,23,23,24,21,22,22,23,23,24,22,23,23,24,24,25,22,23,23,24,24,25,23,24,24,25,25,26] --- --- >>> lift4 (\a b c d -> a + b + c + d) (Full 7) (Full 8) (Full 9) (Full 10) --- Full 34 --- --- >>> lift4 (\a b c d -> a + b + c + d) (Full 7) (Full 8) Empty (Full 10) --- Empty --- --- >>> lift4 (\a b c d -> a + b + c + d) Empty (Full 8) (Full 9) (Full 10) --- Empty --- --- >>> lift4 (\a b c d -> a + b + c + d) Empty Empty (Full 9) (Full 10) --- Empty --- --- >>> lift4 (\a b c d -> a + b + c + d) len sum product (sum . filter even) (listh [4,5,6]) --- 148 -lift4 :: - Monad m => - (a -> b -> c -> d -> e) - -> m a - -> m b - -> m c - -> m d - -> m e -lift4 = - error "todo" - --- Exercise 16 --- Relative Difficulty: 3 --- --- | Sequences a list of structures to a structure of list. --- --- >>> seequence (Id 7 :. Id 8 :. Id 9 :. Nil) --- Id [7,8,9] --- --- >>> seequence ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) --- [[1,1],[1,2],[2,1],[2,2],[3,1],[3,2]] --- --- >>> seequence (Full 7 :. Empty :. Nil) --- Empty --- --- >>> seequence (Full 7 :. Full 8 :. Nil) --- Full [7,8] --- --- >>> seequence ((*10) :. (+2) :. Nil) 6 --- [60,8] -seequence :: - Monad m => - List (m a) - -> m (List a) -seequence = - error "todo" - --- Exercise 17 --- Relative Difficulty: 3 --- --- | Traverse (map) a list of values with an effect. --- --- >>> traaverse (\n -> Id (n + 4)) (1 :. 2 :. 3 :. Nil) --- Id [5,6,7] --- --- >>> traaverse (\n -> n :. n * 2 :. Nil) (1 :. 2 :. 3 :. Nil) --- [[1,2,3],[1,2,6],[1,4,3],[1,4,6],[2,2,3],[2,2,6],[2,4,3],[2,4,6]] --- --- >>> traaverse (\n -> if n < 7 then Full (n * 3) else Empty) (1 :. 2 :. 3 :. Nil) --- Full [3,6,9] --- --- >>> traaverse (\n -> if n < 7 then Full (n * 3) else Empty) (1 :. 2 :. 3 :. 14 :. Nil) --- Empty --- --- >>> traaverse (*) (1 :. 2 :. 3 :. Nil) 15 --- [15,30,45] -traaverse :: - Monad m => - (a -> m b) - -> List a - -> m (List b) -traaverse = - error "todo" - --- Exercise 18 --- Relative Difficulty: 4 --- --- | Replicate an effect a given number of times. --- --- >>> reeplicate 4 (Id "hi") --- Id ["hi","hi","hi","hi"] --- --- >>> reeplicate 4 (Full "hi") --- Full ["hi","hi","hi","hi"] --- --- >>> reeplicate 4 Empty --- Empty --- --- >>> reeplicate 4 (*2) 5 --- [10,10,10,10] -reeplicate :: - Monad m => - Int - -> m a - -> m (List a) -reeplicate = - error "todo" - --- Exercise 19 --- Relative Difficulty: 9 --- --- | Filter a list with a predicate that produces an effect. --- --- >>> filtering (Id . even) (4 :. 5 :. 6 :. Nil) --- Id [4,6] --- --- >>> filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. Nil) --- Full [4,5,6] --- --- >>> filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. 7 :. 8 :. 9 :. Nil) --- Full [4,5,6,7] --- --- >>> filtering (\a -> if a > 13 then Empty else Full (a <= 7)) (4 :. 5 :. 6 :. 13 :. 14 :. Nil) --- Empty --- --- >>> filtering (>) (4 :. 5 :. 6 :. 7 :. 8 :. 9 :. 10 :. 11 :. 12 :. Nil) 8 --- [9,10,11,12] -filtering :: - Monad m => - (a -> m Bool) - -> List a - -> m (List a) -filtering = - error "todo" - ------------------------ --- SUPPORT LIBRARIES -- ------------------------ - -instance Monad IO where - bind = - (=<<) - return = - P.return - -instance Monad [] where - bind = (P.=<<) - return = P.return - -instance Monad Maybe where - bind = (P.=<<) - return = P.return diff --git a/src/Parser/JsonValue.hs b/src/Parser/JsonValue.hs deleted file mode 100644 index 7397ae4..0000000 --- a/src/Parser/JsonValue.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Parser.JsonValue where - -type Assoc = [(String, JsonValue)] - -data JsonValue = - JsonString String - | JsonRational Bool !Rational - | JsonObject Assoc - | JsonArray [JsonValue] - | JsonTrue - | JsonFalse - | JsonNull - deriving (Show, Eq) diff --git a/src/Structure/BKTree.hs b/src/Structure/BKTree.hs deleted file mode 100644 index a346b83..0000000 --- a/src/Structure/BKTree.hs +++ /dev/null @@ -1,134 +0,0 @@ -module Structure.BKTree -( - BKTree -, empty -, bktree -, isEmpty -, null -, size -, (.:.) -, member -, withinDistance -, fromWords -, fromDictionaryFile -) where - -import Structure.MetricSpace -import Data.Map(Map) -import qualified Data.Map as M -import Data.Foldable -import qualified Data.Foldable as F -import Data.Monoid - -data BKTree a = - Node a !Int (BMap a) - | Leaf - deriving (Eq, Show) - -empty :: - BKTree a -empty = - error "todo" - -instance MetricSpace a => Monoid (BKTree a) where - mempty = - error "todo" - mappend = - error "todo" - mconcat = - error "todo" - -instance Foldable BKTree where - foldl = - error "todo" - foldr = - error "todo" - -bktree :: - (MetricSpace a, Foldable f) => - f a - -> BKTree a -bktree = - error "todo" - -isEmpty :: - BKTree a - -> Bool -isEmpty = - error "todo" - -size :: - BKTree a - -> Int -size = - error "todo" - -(.:.) :: - MetricSpace a => - a - -> BKTree a - -> BKTree a -(.:.) = - error "todo" - -infixr 5 .:. - -member :: - MetricSpace a => - a - -> BKTree a - -> Bool -member = - error "todo" - -withinDistance :: - MetricSpace a => - Int - -> a - -> BKTree a - -> [(Int, a)] -withinDistance = - error "todo" - -fromWords :: - String - -> BKTree String -fromWords = - error "todo" - -fromDictionaryFile :: - FilePath - -> IO (BKTree String) -fromDictionaryFile = - error "todo" - --- not exported - -type BMap a = - Map Int (BKTree a) - -asList :: - BKTree a - -> [a] -asList Leaf = - [] -asList (Node a _ m) = - a : (fmap snd (M.toList m) >>= asList) - -usingMap :: - (BMap a -> x) - -> x - -> BKTree a - -> x -usingMap _ l Leaf = - l -usingMap f _ (Node _ _ m) = - f m - -breakMap :: - Int - -> Int - -> BMap a - -> BMap a -breakMap d n m = - fst $ M.split (d + n + 1) (snd $ M.split (d - n - 1) m) diff --git a/src/Structure/Lens.hs b/src/Structure/Lens.hs deleted file mode 100644 index 472d6d1..0000000 --- a/src/Structure/Lens.hs +++ /dev/null @@ -1,440 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Structure.Lens where - -import Core -import Data.List -import Monad.State -import Monad.Functor -import Structure.ListZipper - --- $setup --- >>> import Core(Num(..), reverse, fst, snd) - -data Address = - Address - String -- street - String -- suburb - deriving Eq - --- an employee has an address -data Employee = - Employee - String -- name - Int -- age - Address - deriving Eq - --- a company has an address, a CEO (employee) and a list of employees -data Company = - Company - String -- name - Address - Employee -- CEO - [Employee] -- employees - deriving Eq - --- | An example of a company value. --- --- >>> company --- ACME located at Acme St, Acmeville with CEO Bob aged 13 from Bob St, Bobville and employees; [Mary aged 14 from Mary St, Maryville,Fred aged 15 from Fred St, Fredville] -company :: - Company -company = - Company - "ACME" - (Address - "Acme St" - "Acmeville") - (Employee - "Bob" - 13 - (Address - "Bob St" - "Bobville")) - [ - Employee - "Mary" - 14 - (Address - "Mary St" - "Maryville") - , Employee - "Fred" - 15 - (Address - "Fred St" - "Fredville") - ] - -instance Show Address where - show (Address street suburb) = - concat [street, ", ", suburb] - -instance Show Employee where - show (Employee name age address) = - unwords [name, "aged", show age, "from", show address] - -instance Show Company where - show (Company name address ceo employees) = - unwords [name, "located at", show address, "with CEO", show ceo, "and employees;", show employees] - --- Problem --- Modify the suburb of the address of the employees of a company -updateSuburbs1 :: - (String -> String) - -> Company - -> Company -updateSuburbs1 f (Company name address ceo employees) = - Company name address ceo (map (\(Employee ename age (Address street suburb)) -> Employee ename age (Address street (f suburb))) employees) - -- ^ application - -- ick! - --- | A lens is a pair of set and get. --- --- The type parameter 'a' denotes the target object. --- The type parameter 'b' denotes the field object. -data Lens a b = - Lens (a -> b -> a) (a -> b) - --- A lens on the address field of a suburb target. -suburbAddress :: - Lens Address String -suburbAddress = - Lens - (\(Address street _) suburb -> Address street suburb) - (\(Address _ suburb) -> suburb) - --- A lens on the employee field of an address target. -employeeAddress :: - Lens Employee Address -employeeAddress = - Lens - (\(Employee name age _) address -> Employee name age address) - (\(Employee _ _ address) -> address) - --- A lens on the employees field of a company target. -companyEmployees :: - Lens Company [Employee] -companyEmployees = - Lens - (\(Company name address ceo _) employees -> Company name address ceo employees) - (\(Company _ _ _ employees) -> employees) - --- A lens on the name field of a company target. -companyName :: - Lens Company String -companyName = - Lens - (\(Company _ address ceo employees) name -> Company name address ceo employees) - (\(Company name _ _ _) -> name) - --- Exercise 1 --- --- | Given a lens and a target object, return its field object. --- --- >>> getL companyName company --- "ACME" -getL :: - Lens a b - -> a - -> b -getL = - error "todo" - --- Exercise 2 --- --- | Given a lens, a target object and a field object, return a new target object with the field set. --- --- >>> setL companyName company "Mickey" --- Mickey located at Acme St, Acmeville with CEO Bob aged 13 from Bob St, Bobville and employees; [Mary aged 14 from Mary St, Maryville,Fred aged 15 from Fred St, Fredville] -setL :: - Lens a b - -> a - -> b - -> a -setL = - error "todo" - --- Exercise 3 --- --- | Produce the lens for the first element of a pair. --- --- >>> getL fstL ("hi", 3) --- "hi" --- --- >>> setL fstL ("hi", 3) "bye" --- ("bye",3) -fstL :: - Lens (a, b) a -fstL = - error "todo" - --- Exercise 4 --- --- | Produce the lens for the second element of a pair. --- --- >>> getL sndL ("hi", 3) --- 3 --- --- >>> setL sndL ("hi", 3) 4 --- ("hi",4) -sndL :: - Lens (a, b) b -sndL = - error "todo" - --- Exercise 5 --- --- | Lens composition. --- Given lens (a to b) and lens (b to c), produce lens (a to c). --- --- >>> getL (fstL .@ sndL) (("hi", 3), [7,8,9]) --- 3 --- --- >>> setL (fstL .@ sndL) (("hi", 3), [7,8,9]) 4 --- (("hi",4),[7,8,9]) -(.@) :: - Lens a b - -> Lens b c - -> Lens a c -(.@) = - error "todo" - --- Exercise 6 --- --- | Lens identity. --- Produce lens that /does nothing/. --- --- prop> getL identityL (x :: Int) == x --- --- prop> setL identityL x (y :: Int) == y -identityL :: - Lens a a -identityL = - error "todo" - --- Exercise 7 --- --- | Lens modification. --- Given a lens and a modification function on the field object --- and a target object, return a target with the function applied at that field. --- --- >>> modify fstL (+10) (4, "hi") --- (14,"hi") -modify :: - Lens a b - -> (b -> b) - -> a - -> a -modify = - error "todo" - --- Exercise 8 --- --- | Lens modification in a functor. --- Given two lenses, one with a functor-like field object, --- run the given modification function on the given target object. --- --- >>> (fstL ..@ sndL) (+10) ([("hi", 3)], 44) --- ([("hi",13)],44) -(..@) :: - Functor f => - Lens a (f a1) - -> Lens a1 b - -> (b -> b) - -> a - -> a -(..@) = - error "todo" - --- Exercise 9 --- --- | Given an isomorphism, produce a lens. --- --- >>> getL (iso reverse reverse) [1,2,3] --- [3,2,1] --- --- >>> setL (iso reverse reverse) [1,2,3] [4,5,6] --- [6,5,4] -iso :: - (a -> b) - -> (b -> a) - -> Lens a b -iso = - error "todo" - --- Exercise 10 --- --- | Given two lenses, produce a lens that switches on Either. --- --- >>> getL (fstL |.| sndL) (Left ("hi", 3)) --- "hi" --- --- >>> getL (fstL |.| sndL) (Right ("hi", 3)) --- 3 --- --- >>> setL (fstL |.| sndL) (Left ("hi", 3)) "bye" --- Left ("bye",3) --- --- >>> setL (fstL |.| sndL) (Right ("hi", 3)) 4 --- Right ("hi",4) -(|.|) :: - Lens a c - -> Lens b c - -> Lens (Either a b) c -(|.|) = - error "todo" - --- Exercise 11 --- --- | Given two lenses, produce a lens that combines on their product. --- --- >>> getL (fstL *.* sndL) (("hi", 3), ("bye", 4)) --- ("hi",4) --- --- >>> setL (fstL *.* sndL) (("hi", 3), ("bye", 4)) ("thigh", 5) --- (("thigh",3),("bye",5)) -(*.*) :: - Lens a b - -> Lens c d - -> Lens (a, c) (b, d) -(*.*) = - error "todo" - --- Exercise 12 --- --- | Given a lens, produce a state object. --- --- >>> runState (stateL fstL) ("hi", 3) --- ("hi",("hi",3)) --- --- >>> runState (stateL sndL) ("hi", 3) --- (3,("hi",3)) -stateL :: - Lens a b - -> State a b -stateL = - error "todo" - --- Exercise 13 --- --- | Modify the suburb of a company. --- --- /Tip:/ Use companyEmployees, employeeAddress, suburbAddress. -updateSuburbs2 :: - (String -> String) - -> Company - -> Company -updateSuburbs2 = - error "todo" - --- | A store is the pair of a function from field to target and a field. -data Store a b = - Store (a -> b) a - -strPos :: - Store a b - -> a -strPos (Store _ g) = - g - -strPut :: - Store a b - -> a - -> b -strPut (Store s _) = - s - --- Exercise 14 --- | Store is a functor. --- --- >>> strPut (fmap (+10) (Store (*2) 3)) 5 --- 20 --- --- prop> strPos (fmap (+10) (Store (*2) x)) == (x :: Int) -instance Functor (Store a) where - fmap = - error "todo" - --- Exercise 15 --- | Store duplicates. -instance Extend (Store a) where - (<<=) = - error "todo" - --- Exercise 16 --- | Store is a comonad. -instance Comonad (Store a) where - counit = - error "todo" - --- | An alternative representation of a lens. --- --- A function that takes a target object to a store, --- which is a pair of values: --- --- * field -> target --- --- * field -data SLens target field = - SLens (target -> Store field target) - --- | The lens for the first element of a pair. -sfstL :: - SLens (a, b) a -sfstL = - SLens (\(a, b) -> Store (\a' -> (a', b)) a) - --- | The lens for the first element of a pair. -ssndL :: - SLens (a, b) b -ssndL = - SLens (\(a, b) -> Store (\b' -> (a, b')) b) - --- Exercise 17 --- | Write the get function for the alternative lens. --- --- >>> sgetL sfstL ("hi", 3) --- "hi" -sgetL :: - SLens a b - -> a - -> b -sgetL = - error "todo" - --- Exercise 18 --- | Write the set function for the alternative lens. --- --- >>> ssetL sfstL ("hi", 3) "bye" --- ("bye",3) -ssetL :: - SLens a b - -> a - -> b - -> a -ssetL = - error "todo" - --- Exercise 19 --- | Write the isomorphism between the two lens structures. --- --- prop> getL fstL x == getL (snd equivalent sfstL) (x :: (Int, String)) --- --- prop> setL sndL x y == setL (snd equivalent ssndL) (x :: (Int, String)) y --- --- prop> sgetL sfstL x == sgetL (fst equivalent fstL) x --- --- prop> ssetL ssndL x y == ssetL (fst equivalent sndL) (x :: (Int, String)) y -equivalent :: - ( - Lens a b -> SLens a b - , SLens a b -> Lens a b - ) -equivalent = - error "todo" - -infixr 1 ..@ - -infixr 2 .@ diff --git a/src/Structure/List.hs b/src/Structure/List.hs deleted file mode 100644 index 0c87a53..0000000 --- a/src/Structure/List.hs +++ /dev/null @@ -1,347 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-} - --- + Complete the 10 exercises below by filling out the function bodies. --- Replace the function bodies (error "todo") with an appropriate solution. --- + These exercises may be done in any order, however: --- Exercises are generally increasing in difficulty, though some people may find later exercise easier. --- + Bonus for using the provided functions or for using one exercise solution to help solve another. --- + Approach with your best available intuition; just dive in and do what you can! - --- TOTAL marks: /66 - -module Structure.List where - -import Core -import Intro.Optional - --- $setup --- >>> import Test.QuickCheck --- >>> import Core(even, id, const) --- >>> import qualified Prelude as P(fmap) --- >>> instance Arbitrary a => Arbitrary (List a) where arbitrary = P.fmap (foldr (:.) Nil) arbitrary - --- BEGIN Helper functions and data types - --- The custom list type -data List t = Nil | t :. List t deriving Eq - --- Right-associative -infixr 5 :. - -instance Show t => Show (List t) where - show = show . foldRight (:) [] - --- The list of integers from zero to infinity. -infinity :: - List Integer -infinity = - let inf x = x :. inf (x+1) - in inf 0 - --- functions over List that you may consider using -foldRight :: (a -> b -> b) -> b -> List a -> b -foldRight _ b Nil = b -foldRight f b (h :. t) = f h (foldRight f b t) - -foldLeft :: (b -> a -> b) -> b -> List a -> b -foldLeft _ b Nil = b -foldLeft f b (h :. t) = let b' = f b h in b' `seq` foldLeft f b' t - --- END Helper functions and data types - --- BEGIN Exercises - --- Exercise 1 --- Relative Difficulty: 1 --- Correctness: 2.0 marks --- Performance: 0.5 mark --- Elegance: 0.5 marks --- Total: 3 --- --- | Returns the head of the list or the given default. --- --- >>> headOr 3 (1 :. 2 :. Nil) --- 1 --- --- >>> headOr 3 Nil --- 3 --- --- prop> x `headOr` infinity == 0 --- --- prop> x `headOr` Nil == x -headOr :: - a - -> List a - -> a -headOr = - error "todo" - --- | The product of the elements of a list. --- --- >>> product (1 :. 2 :. 3 :. Nil) --- 6 --- --- >>> product (1 :. 2 :. 3 :. 4 :. Nil) --- 24 -product :: - List Int - -> Int -product = - foldLeft (*) 1 - --- Exercise 2 --- Relative Difficulty: 2 --- Correctness: 2.5 marks --- Performance: 1 mark --- Elegance: 0.5 marks --- Total: 4 --- --- | Sum the elements of the list. --- --- >>> sum (1 :. 2 :. 3 :. Nil) --- 6 --- --- >>> sum (1 :. 2 :. 3 :. 4 :. Nil) --- 10 --- --- prop> foldLeft (-) (sum x) x == 0 -sum :: - List Int - -> Int -sum = - error "todo" - --- Exercise 3 --- Relative Difficulty: 2 --- Correctness: 2.5 marks --- Performance: 1 mark --- Elegance: 0.5 marks --- Total: 4 --- --- | Return the length of the list. --- --- >>> len (1 :. 2 :. 3 :. Nil) --- 3 --- --- prop> sum (map (const 1) x) == len x -len :: - List a - -> Int -len = - error "todo" - --- Exercise 4 --- Relative Difficulty: 5 --- Correctness: 4.5 marks --- Performance: 1.0 mark --- Elegance: 1.5 marks --- Total: 7 --- --- | Map the given function on each element of the list. --- --- >>> map (+10) (1 :. 2 :. 3 :. Nil) --- [11,12,13] --- --- prop> headOr x (map (+1) infinity) == 1 --- --- prop> map id x == x -map :: - (a -> b) - -> List a - -> List b -map = - error "todo" - --- Exercise 5 --- Relative Difficulty: 5 --- Correctness: 4.5 marks --- Performance: 1.5 marks --- Elegance: 1 mark --- Total: 7 --- --- | Return elements satisfying the given predicate. --- --- >>> filter even (1 :. 2 :. 3 :. 4 :. 5 :. Nil) --- [2,4] --- --- prop> headOr x (filter (const True) infinity) == 0 --- --- prop> filter (const True) x == x --- --- prop> filter (const False) x == Nil -filter :: - (a -> Bool) - -> List a - -> List a -filter = - error "todo" - --- Exercise 6 --- Relative Difficulty: 5 --- Correctness: 4.5 marks --- Performance: 1.5 marks --- Elegance: 1 mark --- Total: 7 --- --- | Append two lists to a new list. --- --- >>> append (1 :. 2 :. 3 :. Nil) (4 :. 5 :. 6 :. Nil) --- [1,2,3,4,5,6] --- --- prop> headOr x (Nil `append` infinity) == 0 --- --- prop> headOr x (y `append` infinity) == headOr 0 y --- --- prop> (x `append` y) `append` z == x `append` (y `append` z) --- --- prop> append x Nil == x -append :: - List a - -> List a - -> List a -append = - error "todo" - --- Exercise 7 --- Relative Difficulty: 5 --- Correctness: 4.5 marks --- Performance: 1.5 marks --- Elegance: 1 mark --- Total: 7 --- --- | Flatten a list of lists to a list. --- --- >>> flatten ((1 :. 2 :. 3 :. Nil) :. (4 :. 5 :. 6 :. Nil) :. (7 :. 8 :. 9 :. Nil) :. Nil) --- [1,2,3,4,5,6,7,8,9] --- --- prop> headOr x (flatten (infinity :. y :. Nil)) == 0 --- --- prop> headOr x (flatten (y :. infinity :. Nil)) == headOr 0 y --- --- prop> sum (map len x) == len (flatten x) -flatten :: - List (List a) - -> List a -flatten = - error "todo" - --- Exercise 8 --- Relative Difficulty: 7 --- Correctness: 5.0 marks --- Performance: 1.5 marks --- Elegance: 1.5 mark --- Total: 8 --- --- | Map a function then flatten to a list. --- --- >>> flatMap (\x -> x :. x + 1 :. x + 2 :. Nil) (1 :. 2 :. 3 :. Nil) --- [1,2,3,2,3,4,3,4,5] --- --- prop> headOr x (flatMap id (infinity :. y :. Nil)) == 0 --- --- prop> headOr x (flatMap id (y :. infinity :. Nil)) == headOr 0 y --- --- prop> flatMap id (x :: List (List Int)) == flatten x -flatMap :: - (a -> List b) - -> List a - -> List b -flatMap = - error "todo" - --- Exercise 9 --- Relative Difficulty: 8 --- Correctness: 3.5 marks --- Performance: 2.0 marks --- Elegance: 3.5 marks --- Total: 9 --- --- | Convert a list of optional values to an optional list of values. --- --- * If the list contains all `Full` values, --- then return `Full` list of values. --- --- * If the list contains one or more `Empty` values, --- then return `Empty`. --- --- * The only time `Empty` is returned is --- when the list contains one or more `Empty` values. --- --- >>> seqOptional (Full 1 :. Full 10 :. Nil) --- Full [1,10] --- --- >>> seqOptional Nil --- Full [] --- --- >>> seqOptional (Full 1 :. Full 10 :. Empty :. Nil) --- Empty --- --- >>> seqOptional (Empty :. map Full infinity) --- Empty -seqOptional :: - List (Optional a) - -> Optional (List a) -seqOptional = - error "todo" - --- Exercise 10 --- --- | Find the first element in the list matching the predicate. --- --- >>> find even (1 :. 3 :. 5 :. Nil) --- Empty --- --- >>> find even Nil --- Empty --- --- >>> find even (1 :. 2 :. 3 :. 5 :. Nil) --- Full 2 --- --- >>> find even (1 :. 2 :. 3 :. 4 :. 5 :. Nil) --- Full 2 --- --- >>> find (const True) infinity --- Full 0 -find :: - (a -> Bool) - -> List a - -> Optional a -find = - error "todo" - --- Exercise 11 --- Relative Difficulty: 10 --- Correctness: 5.0 marks --- Performance: 2.5 marks --- Elegance: 2.5 marks --- Total: 10 --- --- | Reverse a list. --- --- >>> rev (1 :. 2 :. 3 :. Nil) --- [3,2,1] --- --- prop> (rev . rev) x == x -rev :: - List a - -> List a -rev = - error "todo" - --- END Exercises - -hlist :: - List a - -> [a] -hlist = - foldRight (:) [] - -listh :: - [a] - -> List a -listh = - foldr (:.) Nil - -instance IsString (List Char) where - fromString = - listh \ No newline at end of file diff --git a/src/Structure/MetricSpace.hs b/src/Structure/MetricSpace.hs deleted file mode 100644 index a64c052..0000000 --- a/src/Structure/MetricSpace.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Structure.MetricSpace where - -import Algorithm.EditDistance - -class Eq a => MetricSpace a where - (<-->) :: - a - -> a - -> Int - -instance Eq a => MetricSpace [a] where - (<-->) = - editDistance -