Haskell

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.hs

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.hs

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.hs

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.hs

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)

project: Polymorph.prj

Shape.hs
Circle.hs
Rectangle.hs
Polymorph.hs

Polymorphism Test

:project Polymorph.prj
main

Output

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

Chris Rathman / Chris.Rathman@tx.rr.com