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 |