[incr Tcl]

class Shape {
   variable x
   variable y

   # constructor & destructor for the Shape class
   constructor {initx inity} {
      setX $initx
      setY $inity
   }
   destructor {
   }

   # get the x & y coordinates for the object
   method getX {} {
      return $x
   }
   method getY {} {
      return $y
   }

   # set the x & y coordinates for the object
   method setX {newx} {
      set x $newx
   }
   method setY {newy} {
      set y $newy
   }

   #move the x & y position of the object
   method moveTo {newx newy} {
      setX $newx
      setY $newy
   }
   method rMoveTo {deltax deltay} {
      moveTo [expr [getX] + $deltax] [expr [getY] + $deltay]
   }
}

class Rectangle {
   inherit Shape
   variable width
   variable height

   # constructor & destructor for the Rectangle class
   constructor {initx inity initwidth initheight} {
      Shape::constructor $initx $inity
   } {
      setWidth $initwidth
      setHeight $initheight
   }
   destructor {
   }

   # get the width & height for the object
   method getWidth {} {
      return $width
   }
   method getHeight {} {
      return $height
   }

   # set the width & height for the object
   method setWidth {newwidth} {
      set width $newwidth
   }
   method setHeight {newheight} {
      set height $newheight
   }

   # draw the rectangle
   method draw {} {
      puts "Drawing a Rectangle at:($x,$y), width $width, height $height"
   }
}

class Circle {
   inherit Shape
   variable radius

   # constructor & destructor for the Circle class
   constructor {initx inity initradius} {
      Shape::constructor $initx $inity
   } {
      setRadius $initradius
   }
   destructor {
   }

   # get the radius for the object
   method getRadius {} {
      return $radius
   }

   # set the radius for the object
   method setRadius {newradius} {
      set radius $newradius
   }

   # draw the circle
   method draw {} {
      puts "Drawing a Circle at:($x,$y), radius $radius"
   }
}

proc polymorph {} {
   # declare and initialize an associative array
   set scribble(0) 0
   set scribble(1) 0

   # set up some shape instances
   Rectangle scribble(0) 10 20 5 6
   Circle scribble(1) 15 25 8

   # iterate through the array and handle shapes polymorphically
   foreach keyitem [array names scribble] {
      scribble($keyitem) draw
      scribble($keyitem) rMoveTo 100 100
      scribble($keyitem) draw
   }

   # access a rectangle specific function
   Rectangle arectangle 0 0 15 15
   arectangle setWidth 30
   arectangle draw

   # cleanup - delete the object instances
   foreach keyitem [array names scribble] {
      delete object scribble($keyitem)
   }
   delete object arectangle
}

source Shape.tcl
source Rectangle.tcl
source Circle.tcl
source Polymorph.tcl
polymorph

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