Contributed by Chris Rathman
Note: This version uses the Existential Type extensions available in Hugs. It should also run okay under GHC but I haven't tested it. I also wrote a Haskell '98 version that sticks to the standards.
module Polymorph(main)
where
import Shape
import Circle
import Rectangle
main =
do
-- handle the shapes polymorphically
drawloop scribble
-- handle rectangle specific instance
draw (setWidth arectangle 30)
where
-- create some shape instances (using existential wrapper)
scribble = [
MakeExistentialShape (MakeRectangle 10 20 5 6),
MakeExistentialShape (MakeCircle 15 25 8)]
-- create a rectangle instance
arectangle = (MakeRectangle 0 0 15 15)
-- iterate through the list of shapes and draw
drawloop [] = return True
drawloop (x:xs) =
do
draw x
draw (rMoveTo x 100 100)
drawloop xs
|
module Shape(Shape, ExistentialShape, MakeExistentialShape, getX, getY, setX, setY, moveTo, rMoveTo, draw)
where
-- declare method interfaces for the shape superclass
class Shape a where
getX :: a -> Int
getY :: a -> Int
setX :: a -> Int -> a
setY :: a -> Int -> a
moveTo :: a -> Int -> Int -> a
rMoveTo :: a -> Int -> Int -> a
draw :: a -> IO()
-- declare the constructor for the existential type
data ExistentialShape =
forall a. Shape a => MakeExistentialShape a
-- map the methods for the existential type
instance Shape ExistentialShape where
getX (MakeExistentialShape a) = getX a
getY (MakeExistentialShape a) = getY a
setX (MakeExistentialShape a) newx = MakeExistentialShape(setX a newx)
setY (MakeExistentialShape a) newy = MakeExistentialShape(setY a newy)
moveTo (MakeExistentialShape a) newx newy = MakeExistentialShape(moveTo a newx newy)
rMoveTo (MakeExistentialShape a) deltax deltay = MakeExistentialShape(rMoveTo a deltax deltay)
draw (MakeExistentialShape a) = draw a
|
module Circle(Circle, MakeCircle, getRadius, setRadius)
where
import Shape
-- declare method interfaces for circle subclass
class Shape a => Circle a where
getRadius :: a -> Int
setRadius :: a -> Int -> a
-- define the methods for shape superclass
instance Shape CircleInstance where
getX = x
getY = y
setX a newx = a {x = newx}
setY a newy = a {y = newy}
moveTo a newx newy = a {x = newx, y = newy}
rMoveTo a deltax deltay = a {x = ((getX a) + deltax), y = ((getY a) + deltay)}
draw a =
putStrLn ("Drawing a Circle at:(" ++ (show (getX a)) ++ "," ++ (show (getY a)) ++
"), radius " ++ (show (getRadius a)))
-- define the methods for circle subclass
instance Circle CircleInstance where
getRadius = radius
setRadius a newradius = a {radius = newradius}
-- declare the constructor for circle class
data CircleInstance = MakeCircle {x, y, radius :: Int}
deriving(Eq, Show)
|
module Rectangle(Rectangle, MakeRectangle, getWidth, getHeight, setWidth, setHeight)
where
import Shape
-- declare method interfaces for rectangle subclass
class Shape a => Rectangle a where
getWidth :: a -> Int
getHeight :: a -> Int
setWidth :: a -> Int -> a
setHeight :: a -> Int -> a
-- define the methods for shape superclass
instance Shape RectangleInstance where
getX = x
getY = y
setX a newx = a {x = newx}
setY a newy = a {y = newy}
moveTo a newx newy = a {x = newx, y = newy}
rMoveTo a deltax deltay = a {x = ((getX a) + deltax), y = ((getY a) + deltay)}
draw a =
putStrLn ("Drawing a Rectangle at:(" ++ (show (getX a)) ++ "," ++ (show (getY a)) ++
"), width " ++ (show (getWidth a)) ++ ", height " ++ (show (getHeight a)))
-- define the methods for rectangle subclass
instance Rectangle RectangleInstance where
getWidth = width
getHeight = height
setWidth a newwidth = a {width = newwidth}
setHeight a newheight = a {height = newheight}
-- declare the constructor for rectangle class
data RectangleInstance = MakeRectangle {x, y, width, height :: Int}
deriving(Eq, Show)
|
Shape.hs Circle.hs Rectangle.hs Polymorph.hs |
:project Polymorph.prj main |
Drawing a Rectangle at:(10,20), width 5, height 6 Drawing a Rectangle at:(110,120), width 5, height 6 Drawing a Circle at:(15,25), radius 8 Drawing a Circle at:(115,125), radius 8 Drawing a Rectangle at:(0,0), width 30, height 15 |