-- Drawable shapes
-- An example of an abstract data type in Haskell. This example
-- does not use classes, modules or existential type extensions.
-- This code is designed for easy comparison with Shapes-no-oop.cc
-- Note how similar it turned out.
-- An existential type: it's defined solely by its behavior
data Shape = Shape {
draws:: IO (),
offset_by:: (Float,Float) -> Shape,
set_dim:: (Float,Float) -> Shape }
-- A collection of polymorphic values.
-- This should generally be [Shapes].
-- But we define it as a tuple of three shapes to match the definition
-- and the sample code of Shapes in Shapes-no-oop.cc
data Shapes = Shapes (Shape, Shape, Shape)
draw:: Shapes -> IO ()
draw (Shapes (s1,s2,s3)) = draws s1 >> draws s2 >> draws s3
pack:: Shapes -> Shapes
pack (Shapes (s1,s2,s3)) =
Shapes ( offset_by s1 (0,1),
offset_by s2 (2,3),
offset_by s3 (4,5) )
resize:: Shapes -> Shapes
resize (Shapes (s1,s2,s3)) =
Shapes ( set_dim s1 (10,10),
set_dim s2 (10,11),
set_dim s3 (11,12) )
-- Two concrete instances of the existential Shape value
rectangle:: (Float,Float,Float,Float) -> Shape
rectangle (x,y,width,height) = if width == height
then
square(x,y,width)
else Shape {
draws = mapM_ putStr
[ "Drawing a rectangle [", show x, ", ", show y,
"] - [", show (x+width),
", ", show (y+height), "]\n" ],
offset_by = \ (new_x,new_y) ->
rectangle (x+new_x,y+new_y,width,height),
set_dim = \ (new_width,new_height) ->
rectangle (x,y,new_width,new_height) }
square:: (Float,Float,Float) -> Shape
square (x,y,size) = Shape {
draws = mapM_ putStr
[ "Drawing a square [", show x, ", ", show y,
"] of size ", show size, "\n" ],
offset_by = \ (new_x,new_y) ->
square (x+new_x,y+new_y,size),
set_dim = \ (new_width,new_height) ->
rectangle (x,y,new_width,new_height) }
-- A sample test
main = do {
putStrLn "Instantiating shapes...";
let shapes = Shapes (rectangle (0,0,1,2),
rectangle (0,0,5,5),
rectangle (0,0,7,7))
shapes_packed = pack shapes
shapes_resized = resize shapes_packed
in
do { putStrLn "Drawing ... some rectangles are actually squares";
draw shapes;
putStrLn "Packing ...";
draw shapes_packed;
putStrLn "Resizing ... rectangles turn squares and vice versa";
draw shapes_resized };
putStrLn "\nAll done"
}