HaskellCode/haskellCraft/Chapter14_2.hs at master · DRMPN/HaskellCode

341 lines (225 loc) · 7.63 KB
--------------------------------------------------------------------
-- 	Haskell: The Craft of Functional Programming
-- 	Simon Thompson
-- 	(c) Addison-Wesley, 1999.
-- 	Chapter 14, part 2
--------------------------------------------------------------------
module Chapter14_2 where
import Prelude hiding (Either(..),either,Maybe(..),maybe)
import Chapter14_1 hiding (Name,Shape(..))
-- Algebraic types, part 2
-- ^^^^^^^^^^^^^^^^^^^^^^^
-- Polymorphic algebraic types
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-- A type of pairs of elements, taken from the same type.
data Pairs a = Pr a a
-- and example elements of the type are
pair1 = Pr 2 3    :: Pairs Int
pair2 = Pr [] [3] :: Pairs [Int]
pair3 = Pr [] []  :: Pairs [a]
-- Are the two halves equal?
equalPair :: Eq a => Pairs a -> Bool
equalPair (Pr x y) = (x==y)
-- Defining lists from scratch (which loses some of the special syntax for
data List a = NilList | Cons a (List a)
              deriving (Eq,Ord,Show,Read)
-- Binary trees
-- ^^^^^^^^^^^^
-- Binary trees carrying elements of an arbitrary type.
data Tree a = Nil | Node a (Tree a) (Tree a)
              deriving (Eq,Ord,Show,Read)
-- The depth of a binary tree.
depthT :: Tree a -> Int
depthT Nil            = 0
depthT (Node n t1 t2) = 1 + max (depthT t1) (depthT t2)
-- Turning a tree into a list.
collapse :: Tree a -> [a]
collapse Nil = []
collapse (Node x t1 t2)
  = collapse t1 ++ [x] ++ collapse t2
-- For example,
collapseEG 
 = collapse (Node 12 
               (Node 34 Nil Nil) 
               (Node 3 (Node 17 Nil Nil) Nil))
-- Mapping a function over all elements in a tree, preserving the
-- structure.
mapTree :: (a -> b) -> Tree a -> Tree b
mapTree f Nil = Nil
mapTree f (Node x t1 t2)
  = Node (f x) (mapTree f t1) (mapTree f t2)
-- The union type, Either
-- ^^^^^^^^^^^^^^^^^^^^^^
-- A union type -- defined in the Prelude.lhs.
data Either a b = Left a | Right b
                  deriving (Eq,Ord,Read,Show)
-- Examples
eitherEG1 = Left "Duke of Prunes" :: Either String Int
eitherEG2 = Right 33312           :: Either String Int
-- In the left or the right?
isLeft :: Either a b -> Bool
isLeft (Left _)  = True
isLeft (Right _) = False
-- To define a function from Either a b to c we have to deal with two cases,
either :: (a -> c) -> (b -> c) -> Either a b -> c
either f g (Left x)  = f x
either f g (Right y) = g y
-- If we have a function f::a -> cand we wish to apply it to an element
-- of Either a b, there is a problem: what do we do if the element is
-- in the right-hand side of the Either type? A simple answer is to raise an error
applyLeft :: (a -> c) -> Either a b -> c
applyLeft f (Left x)  = f x
applyLeft f (Right _) = error "applyLeft applied to Right"
-- Arbitrarily branching trees
data GTree a = Leaf a | Gnode [GTree a]
-- Case study: Program Errors
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^
-- This section explores various ways of handling errors raised in program
-- execution.
-- \subsection*{Dummy Values}
-- \index{dummy values at errors}
-- The tail function re-defined to give an empty list when applied to the empty list. 
tl :: [a] -> [a]
tl (_:xs) = xs
tl []     = []
-- Zero returned when division by zero,
divide :: Int -> Int -> Int
divide n m 
  | (m /= 0)    = n `div` m
  | otherwise   = 0
-- Head redefined to give a dummy value on the empty list; the value has
-- to be a parameter.
hd :: a -> [a] -> a
hd y (x:_) = x
hd y []    = y
-- Error types
-- ^^^^^^^^^^^
-- The Maybe type, as defined in the Prelude.lhs,
data Maybe a = Nothing | Just a
               deriving (Eq,Ord,Read,Show)
-- An error-raising division function
errDiv :: Int -> Int -> Maybe Int
errDiv n m 
  | (m /= 0)    = Just (n `div` m)
  | otherwise   = Nothing 
-- The function mapMaybe transmits an error value though the application of
-- the function g. 
mapMaybe :: (a -> b) -> Maybe a -> Maybe b
mapMaybe g Nothing  = Nothing
mapMaybe g (Just x) = Just (g x)
-- In trapping an error, we aim to return a result of type b, from an
-- input of type Maybe a; there are two cases to deal with:
-- normal result (Just); error (Nothing).
maybe :: b -> (a -> b) -> Maybe a -> b
maybe n f Nothing  = n
maybe n f (Just x) = f x
-- Examples
handle1, handle2 :: Int
handle1 = maybe 56 (1+) (mapMaybe (*3) (errDiv 9 0)) 
handle2 = maybe 56 (1+) (mapMaybe (*3) (errDiv 9 1))  
-- Generalising the Maybe type to include an error message in the `Nothing'
data Err a = OK a | Error String
-- Design with Algebraic Data Types
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-- Case study: edit distance
-- ^^^^^^^^^^^^^^^^^^^^^^^^^
-- A type to represent the different sorts of Edit operations.
data Edit = Change Char |
            Copy |
            Delete |
            Insert Char |
            Kill  
            deriving (Eq,Show)
-- Transforming one string into another, optimally,
transform :: String -> String -> [Edit]
transform [] [] = []
transform xs [] = [Kill]
transform [] ys = map Insert ys
transform (x:xs) (y:ys)
  | x==y        = Copy : transform xs ys
  | otherwise   = best [ Delete   : transform xs (y:ys) ,
                         Insert y : transform (x:xs) ys ,
                         Change y : transform xs ys ]
-- How do we choose the best sequence? We choose the one with the lowest
best :: [[Edit]] -> [Edit]
best [x]   = x
best (x:xs) 
  | cost x <= cost b    = x
  | otherwise           = b
      where 
      b = best xs
-- The cost is given by charging one for every operation except copy,
-- which is equivalent to `leave unchanged'.
cost :: [Edit] -> Int
cost = length . filter (/=Copy)
-- Simulation
-- ^^^^^^^^^^
-- NOTE: details of the Simulation case study are collected separately.
-- Algebraic types and type classes
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-- Movable objects
-- ^^^^^^^^^^^^^^^
data Vector = Vec Float Float
class Movable a where
  move      :: Vector -> a -> a
  reflectX  :: a -> a
  reflectY  :: a -> a
  rotate180 :: a -> a
  rotate180 = reflectX . reflectY
data Point = Point Float Float 
             deriving Show
instance Movable Point where
  move (Vec v1 v2) (Point c1 c2) = Point (c1+v1) (c2+v2)
  reflectX (Point c1 c2)  = Point c1 (-c2)
  reflectY (Point c1 c2)  = Point (-c1) c2
  rotate180 (Point c1 c2) = Point (-c1) (-c2)
data Figure = Line Point Point |
              Circle Point Float 
              deriving Show
instance Movable Figure where
  move v (Line p1 p2) = Line (move v p1) (move v p2)
  move v (Circle p r) = Circle (move v p) r
  reflectX (Line p1 p2) = Line (reflectX p1) (reflectX p2)
  reflectX (Circle p r) = Circle (reflectX p) r
  reflectY (Line p1 p2) = Line (reflectY p1) (reflectY p2)
  reflectY (Circle p r) = Circle (reflectY p) r
instance Movable a => Movable [a] where
  move v   = map (move v)
  reflectX = map reflectX
  reflectY = map reflectY
-- Named objects
-- ^^^^^^^^^^^^^
-- Named objects:
class Named a where
  lookName :: a -> String
  giveName :: String -> a -> a
-- A named type ...
data Name a = Pair a String
-- ... as witnessed by the instance declaration.
instance Named (Name a) where
  lookName (Pair obj nm) = nm
  giveName nm (Pair obj _) = (Pair obj nm)
-- Putting together classes
-- ^^^^^^^^^^^^^^^^^^^^^^^^
-- See the text for details of what is going on here.
mapName :: (a -> b) -> Name a -> Name b
mapName f (Pair obj nm) = Pair (f obj) nm
instance Movable a => Movable (Name a) where
  move v   = mapName (move v)
  reflectX = mapName reflectX
  reflectY = mapName reflectY
class (Movable b, Named b) => NamedMovable b
instance Movable a => NamedMovable (Name a)
-- Reasoning about algebraic types
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-- The functions discussed here are all defined elsewhere.
Provide feedback

Saved searches

Use saved searches to filter your results more quickly

FilesExpand file tree

Chapter14_2.hs

Latest commit

History

Chapter14_2.hs

File metadata and controls
