O'Haskell

module Shape

   where

   -- declare method interfaces for the shape superclass
   struct Shape =
      getX :: Cmd Int
      getY :: Cmd Int
      setX :: Int -> Cmd ()
      setY :: Int -> Cmd ()
      moveTo :: Int -> Int -> Cmd ()
      rMoveTo :: Int -> Int -> Cmd ()
      draw :: Cmd ()

module Rectangle

   where

   -- declare method interfaces for rectangle subclass
   struct Rectangle < Shape =
      getWidth :: Cmd Int
      getHeight :: Cmd Int
      setWidth :: Int -> Cmd ()
      setHeight :: Int -> Cmd ()

   -- declare the constructor for the rectangle class
   rectangle (env, initx, inity, initwidth, initheight) =

      -- slots for the object state variables
      template
         x := initx
         y := inity
         width := initwidth
         height := initheight

      -- define the methods for the rectangle class
      in struct

         -- accessors for x & y coordinates
         getX = request
            return x
         getY = request
            return y
         setX newx = action
            x := newx
         setY newy = action
            y := newy

         -- move the x & y coordinates
         moveTo newx newy = action
            x := newx
            y := newy
         rMoveTo deltax deltay = action
            x := x + deltax
            y := y + deltay

         -- accessors for width & height
         getWidth = request
            return width
         getHeight = request
            return height
         setWidth newwidth = action
            width := newwidth
         setHeight newheight = action
            height := newheight

         -- draw the rectangle
         draw = request
            env.putStr("Drawing a Rectangle at:(" ++ (show x) ++ "," ++ (show y) ++
               "), width " ++ (show width) ++ ", height " ++ (show height) ++ "\n")

module Circle

   where

   -- declare method interfaces for circle subclass
   struct Circle < Shape =
      getRadius :: Cmd Int
      setRadius :: Int -> Cmd ()

   -- declare the constructor for the circle class
   circle (env, initx, inity, initradius) =

      -- slots for the object state variables
      template
         x := initx
         y := inity
         radius := initradius

      -- define the methods for the circle class
      in struct

         -- accessors for x & y coordinates
         getX = request
            return x
         getY = request
            return y
         setX newx = action
            x := newx
         setY newy = action
            y := newy

         -- move the x & y coordinates
         moveTo newx newy = action
            x := newx
            y := newy
         rMoveTo deltax deltay = action
            x := x + deltax
            y := y + deltay

         -- accessors for the radius
         getRadius = request
            return radius
         setRadius newradius = action
            radius := newradius

         -- draw the circle
         draw = request
            env.putStr("Drawing a Circle at:(" ++ (show x) ++ "," ++
               (show y) ++ "), radius " ++ (show radius) ++ "\n")

module Polymorph(main)

   where
   import Shape
   import Circle
   import Rectangle

   main env =
      do
         -- create some shape instances
         s1 <- (rectangle (env, 10, 20, 5, 6))
         s2 <- (circle (env, 15, 25, 8))
         let scribble = s1:s2:[]

         -- iterate through the list and handle shapes polymorphically
         drawloop scribble

         -- call a rectangle specific function
         r <- (rectangle (env, 0, 0, 15, 15))
         r.setWidth 30
         r.draw

   drawloop [] = return ()
   drawloop (x:xs) =
      do
         x.draw
         x.rMoveTo 100 100
         x.draw
         drawloop xs

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