Clean

definition module Shape

// declare method interfaces for the shape superclass
class ShapeClass 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 :: *World a -> *World

implementation module Shape
import StdEnv

// declare method interfaces for the shape superclass
class ShapeClass 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 :: *World a -> *World

definition module Rectangle
import Shape

// declare method interfaces for rectangle subclass
class RectangleClass a | ShapeClass a where
   getWidth :: a -> Int
   getHeight :: a -> Int
   setWidth :: a Int -> a
   setHeight :: a Int -> a

// declare the record to hold rectangle parameters
::RectangleRecord

// declare the constructor for rectangle class
MakeRectangle :: Int Int Int Int -> RectangleRecord

// define the methods for shape superclass
instance ShapeClass RectangleRecord

// define the methods for rectangle subclass
instance RectangleClass RectangleRecord

implementation module Rectangle
import StdEnv
import Shape

// declare method interfaces for rectangle subclass
class RectangleClass a | ShapeClass a where
   getWidth :: a -> Int
   getHeight :: a -> Int
   setWidth :: a Int -> a
   setHeight :: a Int -> a

// declare the record to hold rectangle parameters
::RectangleRecord =
   {   x :: Int
   ,   y :: Int
   ,   width :: Int
   ,   height :: Int
   }

// declare the constructor for rectangle class
MakeRectangle :: Int Int Int Int -> RectangleRecord
MakeRectangle initx inity initwidth initheight =
   {   x = initx
   ,   y = inity
   ,   width = initwidth
   ,   height = initheight
   }

// define the methods for shape superclass
instance ShapeClass RectangleRecord where
   getX a = a.x
   getY a = a.y
   setX a newx = {a & x = newx}
   setY a newy = {a & y = newy}
   moveTo a newx newy = {a & x = newx, y = newy}
   rMoveTo a newx newy = {a & x = ((getX a) + newx), y = ((getY a) + newy)}
   draw world a
      #  (console, world) = stdio world
         console = fwrites "Drawing a Rectangle at:(" console
         console = fwritei (getX a) console
         console = fwrites "," console
         console = fwritei (getY a) console
         console = fwrites "), width " console
         console = fwritei (getWidth a) console
         console = fwrites ", height " console
         console = fwritei (getHeight a) console
         console = fwrites "\n" console
         (ok, world) = fclose console world
      |  not ok = abort "Cannot open console"
      = world

// define the methods for rectangle subclass
instance RectangleClass RectangleRecord where
   getWidth a = a.width
   getHeight a = a.height
   setWidth a newwidth = {a & width = newwidth}
   setHeight a newheight = {a & height = newheight}

definition module Circle
import Shape

// declare method interfaces for circle subclass
class CircleClass a | ShapeClass a where
   getRadius :: a -> Int
   setRadius :: a Int -> a

// declare the record to hold circle parameters
::CircleRecord

// declare the constructor for circle class
MakeCircle :: Int Int Int -> CircleRecord

// define the methods for shape superclass
instance ShapeClass CircleRecord

// define the methods for circle subclass
instance CircleClass CircleRecord

implementation module Circle
import StdEnv
import Shape

// declare method interfaces for circle subclass
class CircleClass a | ShapeClass a where
   getRadius :: a -> Int
   setRadius :: a Int -> a

// declare the record to hold circle parameters
::CircleRecord =
   {   x :: Int
   ,   y :: Int
   ,   radius :: Int
   }

// declare the constructor for circle class
MakeCircle :: Int Int Int -> CircleRecord
MakeCircle initx inity initradius =
   {   x = initx
   ,   y = inity
   ,   radius = initradius
   }

// define the methods for shape superclass
instance ShapeClass CircleRecord where
   getX a = a.x
   getY a = a.y
   setX a newx = {a & x = newx}
   setY a newy = {a & y = newy}
   moveTo a newx newy = {a & x = newx, y = newy}
   rMoveTo a newx newy = {a & x = ((getX a) + newx), y = ((getY a) + newy)}
   draw world a
      #  (console, world) = stdio world
         console = fwrites "Drawing a Circle at:(" console
         console = fwritei (getX a) console
         console = fwrites "," console
         console = fwritei (getY a) console
         console = fwrites "), radius " console
         console = fwritei (getRadius a) console
         console = fwrites "\n" console
         (ok, world) = fclose console world
      |  not ok = abort "Cannot open console"
      = world

// define the methods for circle subclass
instance CircleClass CircleRecord where
   getRadius a = a.radius
   setRadius a newradius = {a & radius = newradius}

module Polymorph
import StdEnv
import Shape, Rectangle, Circle

Start :: *World -> *World
Start world
   // handle the shapes polymorphically
   # world = drawloop world scribble1
   # world = drawloop world scribble2

   // handle rectangle specific instance
   # world = draw world arectangle
   # world = draw world (setWidth arectangle 30)

   = world

where
   // create lists containing instances of each shape
   scribble1 = [MakeCircle 15 25 8]
   scribble2 = [MakeRectangle 10 20 5 6]

   // create a rectangle instance
   arectangle = MakeRectangle 0 0 15 15

// iterate through the list of shapes and draw
drawloop world [] = world
drawloop world [head:tail]
   # world = draw world head
   # movedShape = rMoveTo head 100 100
   # world = draw world movedShape
   = drawloop world tail

Drawing a Circle at:(15,25), radius 8
Drawing a Circle at:(115,125), radius 8
Drawing a Rectangle at:(10,20), width 5, height 6
Drawing a Rectangle at:(110,120), width 5, height 6
Drawing a Rectangle at:(0,0), width 15, height 15
Drawing a Rectangle at:(0,0), width 30, height 15
65536