Defining different data constructors for a type, and then defining functions using pattern matching over them resembles ad-hoc polymorphism in other languages a lot:
data Shape = Circle Float | Rectangle Float Float
area :: Shape -> Float
area (Circle r) = pi * r^2
area (Rectangle a b) = a*b
Using type classes you could do
class Shape s where
area :: s -> Float
data Circle = Circle Float
instance Shape Circle where
area (Circle r) = pi * r^2
data Rectangle = Rectangle Float Float
instance Shape Rectangle where
area (Rectangle a b) = a*b
One advantage of the second that I see is that it can be extended without touching existing declarations, in particular it may be your only option. Are there other reasons to prefer one over the other?
To make the 2nd approach work, you have to know the type s at compile time while with the 1st approach you can match runtime values
data Shape = Circle Float | Rectangle Float Float
area :: Shape -> Float
area (Circle r) = pi * r^2
area (Rectangle a b) = a*b
fromString :: String -> [Float] -> Shape
fromString "circle" (r:_) = Circle r
fromString "rectangle" (a:b:_) = Rectangle a b
areaFromString :: String -> [Float] -> Float
areaFromString s params = area $ fromString s params
Difference between Type Class and Algebraic data types
Scala: difference between a typeclass and an ADT?
Type classes vs algebraic data types?
To compare these approaches, it helps to see more than the data type declarations.
Suppose we want to write a Haskell program to parse a shape specification and display it as an ASCII diagram on the screen.
Solution #1
One method is to define our Shape as an ADT:
type Pos = (Float, Float)
type Scalar = Float
data Shape
= Circle Pos Scalar
| Rectangle Pos Scalar Scalar
deriving (Show)
To parse the specification, we'll use Megaparsec. This will require a Parser Shape:
shape :: Parser Shape
shape = Circle <$ char 'C' <*> pos <*> scalar
<|> Rectangle <$ char 'R' <*> pos <*> scalar <* char ',' <*> scalar
plus some additional pos and scalar parsers (see below).
To render the shape, we'll first calculate its bounding box:
data Box = Box Pos Pos deriving (Show)
bbox :: Shape -> Box
bbox (Circle (x,y) r) = Box (x-r,y-r) (x+r,y+r)
bbox (Rectangle (x,y) w h) = Box (x-w/2,y-h/2) (x+w/2,y+h/2)
and then write it to a raster over that bounding box:
type Raster = [[Char]]
render :: Box -> (Int, Int) -> Shape -> Raster
render (Box (x1,y1) (x2,y2)) (cx,cy) s
= [[ if inShape (x,y) s then 'X' else ' '
| x <- [x1',x1'+delta..x2']] | y <- [y1',y1'-delta*caspect..y2']]
where --- ugly computations of x1', etc. go here
This relies on a function that can determine if a raster point is inside the shape or not:
inShape :: Pos -> Shape -> Bool
inShape (x,y) (Circle (cx,cy) r) = sq (x-cx) + sq (y-cy) <= sq r
where sq a = a*a
inShape (x,y) (Rectangle (cx,cy) w h)
= cx-w/2 <= x && x <= cx+w/2
&& cy-h/2 <= y && y <= cy+h/2
After adding some driver/main functions and filling in the details, the full program is:
{-# OPTIONS_GHC -Wall #-}
import Data.Void
import Text.Megaparsec hiding (Pos)
import Text.Megaparsec.Char
type Pos = (Float, Float)
type Scalar = Float
data Shape
= Circle Pos Scalar
| Rectangle Pos Scalar Scalar
deriving (Show)
type Parser = Parsec Void String
shape :: Parser Shape
shape = Circle <$ char 'C' <*> pos <*> scalar
<|> Rectangle <$ char 'R' <*> pos <*> scalar <* char ',' <*> scalar
pos :: Parser Pos
pos = (,) <$ char '(' <*> scalar <* char ',' <*> scalar <* char ')'
scalar :: Parser Scalar
scalar = do
sgn <- option 1 (-1 <$ char '-')
dig1 <- digits
dig2 <- option "" ((:) <$> char '.' <*> digits)
return $ sgn * read (dig1 ++ dig2)
where digits = some digitChar
data Box = Box Pos Pos deriving (Show)
bbox :: Shape -> Box
bbox (Circle (x,y) r) = Box (x-r,y-r) (x+r,y+r)
bbox (Rectangle (x,y) w h) = Box (x-w/2,y-h/2) (x+w/2,y+h/2)
type Raster = [[Char]]
render :: Box -> (Int, Int) -> Shape -> Raster
render (Box (x1,y1) (x2,y2)) (cx,cy) s
= [[ if inShape (x,y) s then 'X' else ' '
| x <- [x1',x1'+delta..x2']] | y <- [y1',y1'-delta*caspect..y2']]
where caspect = 2 -- font character aspect ratio
expand = 1.2 -- expansion of raster beyond bounding box
delta = max ((x2-x1) / fromIntegral cx) ((y2-y1) / fromIntegral cy / caspect)
x1' = (x1+x2)/2 - expand*cx' * delta
x2' = (x1+x2)/2 + expand*cx' * delta
y1' = (y1+y2)/2 + expand*cy' * delta * caspect
y2' = (y1+y2)/2 - expand*cy' * delta * caspect
cx' = fromIntegral cx / 2
cy' = fromIntegral cy / 2
inShape :: Pos -> Shape -> Bool
inShape (x,y) (Circle (cx,cy) r) = sq (x-cx) + sq (y-cy) <= sq r
where sq a = a*a
inShape (x,y) (Rectangle (cx,cy) w h)
= cx-w/2 <= x && x <= cx+w/2
&& cy-h/2 <= y && y <= cy+h/2
driver :: String -> IO ()
driver spec = do
putStrLn "---BEGIN---"
let res = parse (shape <* eof) "(string)" spec
case res of
Left err -> error (errorBundlePretty err)
Right s -> putStrLn $ unlines $ render (bbox s) (40,20) s
putStrLn "---END---"
main :: IO ()
main = do
driver "C(3,8)8" -- circle radius 8 centered at (3,8)
driver "R(-1,6)8,3" -- rectangle centered at (-1,6) w/ dim 8 by 3
It works fine:
λ> main
---BEGIN---
XXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXX
X
---END---
---BEGIN---
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
---END---
Suppose we want to add a shape, like an Octagon. This requires adding an Octagon constructor:
data Shape
= ...
| Octagon Pos Scalar
...
Compiler warnings direct us to add the following cases to our functions:
bbox (Octagon (x,y) w) = Box (x-w/2,y-w/2) (x+w/2,y+w/2)
inShape (x,y) (Octagon (cx,cy) w)
= cx-w/2 <= x && x <= cx+w/2
&& cy-w/2 <= y && y <= cy+w/2
&& abs (x-cx) + abs (y-cy) <= w / sqrt 2
We have to figure out on our own that the parser needs to be modified:
shape = ...
<|> Octagon <$ char 'O' <*> pos <*> scalar
This change requires 7 lines of code added in 4 locations in the source.
Suppose we now want to add an ability to create shapes that consist of unions of other shapes. This change is similar in scope and requires the addition of 7 lines of code in 4 locations.
Finally, suppose we want to add the ability to "render" to a descriptive text format. This requires defining a 5-line function in one location:
description :: Shape -> String
description (Circle c r) = "a circle centered at " ++ show c ++ " with radius " ++ show r
description (Rectangle c w h) = "a rectangle centered at " ++ show c ++ " with width " ++ show w ++ " and height " ++ show h
description (Octagon c w) = "an octagon centered at " ++ show c ++ " with width " ++ show w
description (Union s t) = "the union of " ++ description s ++ " and " ++ description t
The full program follows. It's 94 lines and 3148 characters of source, and it makes no use of advanced Haskell features other than applicative syntax for the parser.
{-# OPTIONS_GHC -Wall #-}
import Data.Void
import Text.Megaparsec hiding (Pos)
import Text.Megaparsec.Char
type Pos = (Float, Float)
type Scalar = Float
data Shape
= Circle Pos Scalar
| Rectangle Pos Scalar Scalar
| Octagon Pos Scalar
| Union Shape Shape
deriving (Show)
type Parser = Parsec Void String
shape :: Parser Shape
shape = Circle <$ char 'C' <*> pos <*> scalar
<|> Rectangle <$ char 'R' <*> pos <*> scalar <* char ',' <*> scalar
<|> Octagon <$ char 'O' <*> pos <*> scalar
<|> Union <$ char 'U' <*> shape <*> shape
pos :: Parser Pos
pos = (,) <$ char '(' <*> scalar <* char ',' <*> scalar <* char ')'
scalar :: Parser Scalar
scalar = do
sgn <- option 1 (-1 <$ char '-')
dig1 <- digits
dig2 <- option "" ((:) <$> char '.' <*> digits)
return $ sgn * read (dig1 ++ dig2)
where digits = some digitChar
data Box = Box Pos Pos deriving (Show)
bbox :: Shape -> Box
bbox (Circle (x,y) r) = Box (x-r,y-r) (x+r,y+r)
bbox (Rectangle (x,y) w h) = Box (x-w/2,y-h/2) (x+w/2,y+h/2)
bbox (Octagon (x,y) w) = Box (x-w/2,y-w/2) (x+w/2,y+w/2)
bbox (Union s t)
= let Box (x1,y1) (x2,y2) = bbox s
Box (x3,y3) (x4,y4) = bbox t
in Box (min x1 x3, min y1 y3) (max x2 x4, max y2 y4)
type Raster = [[Char]]
render :: Box -> (Int, Int) -> Shape -> Raster
render (Box (x1,y1) (x2,y2)) (cx,cy) s
= [[ if inShape (x,y) s then 'X' else ' '
| x <- [x1',x1'+delta..x2']] | y <- [y1',y1'-delta*caspect..y2']]
where caspect = 2 -- font character aspect ratio
expand = 1.2 -- expansion of raster beyond bounding box
delta = max ((x2-x1) / fromIntegral cx) ((y2-y1) / fromIntegral cy / caspect)
x1' = (x1+x2)/2 - expand*cx' * delta
x2' = (x1+x2)/2 + expand*cx' * delta
y1' = (y1+y2)/2 + expand*cy' * delta * caspect
y2' = (y1+y2)/2 - expand*cy' * delta * caspect
cx' = fromIntegral cx / 2
cy' = fromIntegral cy / 2
inShape :: Pos -> Shape -> Bool
inShape (x,y) (Circle (cx,cy) r) = sq (x-cx) + sq (y-cy) <= sq r
where sq a = a*a
inShape (x,y) (Rectangle (cx,cy) w h)
= cx-w/2 <= x && x <= cx+w/2
&& cy-h/2 <= y && y <= cy+h/2
inShape (x,y) (Octagon (cx,cy) w)
= cx-w/2 <= x && x <= cx+w/2
&& cy-w/2 <= y && y <= cy+w/2
&& abs (x-cx) + abs (y-cy) <= w / sqrt 2
inShape p (Union s t) = inShape p s || inShape p t
description :: Shape -> String
description (Circle c r) = "a circle centered at " ++ show c ++ " with radius " ++ show r
description (Rectangle c w h) = "a rectangle centered at " ++ show c ++ " with width " ++ show w ++ " and height " ++ show h
description (Octagon c w) = "an octagon centered at " ++ show c ++ " with width " ++ show w
description (Union s t) = "the union of " ++ description s ++ " and " ++ description t
driver :: String -> IO ()
driver spec = do
putStrLn "---BEGIN---"
let res = parse (shape <* eof) "(string)" spec
case res of
Left err -> error (errorBundlePretty err)
Right s -> do
putStrLn $ unlines $ render (bbox s) (40,20) s
putStrLn $ description s
putStrLn "---END---"
main :: IO ()
main = do
driver "UR(0,0)2,2UC(1,1)0.5C(-1,1)0.5"
Solution #2
A second method of writing this program is to define a Shape class and a collection of instances of this class representing each possible shape. We might spec out the shapes we want to support as follows, without defining any functionality just yet:
class Shape s
data Circle = Circle Pos Scalar deriving (Show)
instance Shape Circle
data Rectangle = Rectangle Pos Scalar Scalar deriving (Show)
instance Shape Rectangle
Now, to parse the parse the shape specification, we'll use Megaparsec. We can't write a Parser Shape, because Shape is a type class. We can write a method for parsing the individual shapes however. This involves adding lines to the class and instances:
class Shape s where
parseShape :: Parser s
instance Shape Circle where
parseShape = Circle <$ char 'C' <*> pos <*> scalar
instance Shape Rectangle where
parseShape = Rectangle <$ char 'R' <*> pos <*> scalar <* char ',' <*> scalar
We can conveniently parse an arbitrary shape by definining an existential type:
data SomeShape = forall s. Shape s => SomeShape s
As tempting as it might seem, the following does not work at all:
someShape :: Parser SomeShape
someShape = SomeShape <$> parseShape
There is, unfortunately, no way to avoid enumerating the individual shapes like so:
someShape :: Parser SomeShape
someShape = SomeShape <$> (parseShape :: Parser Circle)
<|> SomeShape <$> (parseShape :: Parser Rectangle)
Now that we can parse shapes, we'll want to calculate a bounding box. This involves adding the Box type and three lines of the bbox definition to the class and two instances:
data Box = Box Pos Pos deriving (Show)
class Shape s where
...
bbox :: s -> Box
instance Shape Circle where
...
bbox (Circle (x,y) r) = Box (x-r,y-r) (x+r,y+r)
instance Shape Rectangle where
...
bbox (Rectangle (x,y) w h) = Box (x-w/2,y-h/2) (x+w/2,y+h/2)
The rendering function is much the same as before, except for its type signature:
render :: (Shape s) => Box -> (Int, Int) -> s -> Raster
The render function requires an inShape method, which involves adding the three lines of the inShape definition to the class and two instances.
The driver needs to be modified to handle the existential shape. In this case, the fix is easy -- just an additional pattern match on SomeShape:
driver :: String -> IO ()
driver spec = do
putStrLn "---BEGIN---"
let res = parse (someShape <* eof) "(string)" spec
case res of
Left err -> error (errorBundlePretty err)
Right (SomeShape s) -> putStrLn $ unlines $ render (bbox s) (40,20) s
putStrLn "---END---"
The full program follows:
{-# OPTIONS_GHC -Wall #-}
import Data.Void
import Text.Megaparsec hiding (Pos)
import Text.Megaparsec.Char
data Box = Box Pos Pos deriving (Show)
class Shape s where
parseShape :: Parser s
bbox :: s -> Box
inShape :: Pos -> s -> Bool
type Pos = (Float, Float)
type Scalar = Float
data Circle = Circle Pos Scalar deriving (Show)
instance Shape Circle where
parseShape = Circle <$ char 'C' <*> pos <*> scalar
bbox (Circle (x,y) r) = Box (x-r,y-r) (x+r,y+r)
inShape (x,y) (Circle (cx,cy) r) = sq (x-cx) + sq (y-cy) <= sq r
where sq a = a*a
data Rectangle = Rectangle Pos Scalar Scalar deriving (Show)
instance Shape Rectangle where
parseShape = Rectangle <$ char 'R' <*> pos <*> scalar <* char ',' <*> scalar
bbox (Rectangle (x,y) w h) = Box (x-w/2,y-h/2) (x+w/2,y+h/2)
inShape (x,y) (Rectangle (cx,cy) w h)
= cx-w/2 <= x && x <= cx+w/2
&& cy-h/2 <= y && y <= cy+h/2
type Parser = Parsec Void String
pos :: Parser Pos
pos = (,) <$ char '(' <*> scalar <* char ',' <*> scalar <* char ')'
scalar :: Parser Scalar
scalar = do
sgn <- option 1 (-1 <$ char '-')
dig1 <- digits
dig2 <- option "" ((:) <$> char '.' <*> digits)
return $ sgn * read (dig1 ++ dig2)
where digits = some digitChar
data SomeShape = forall s. Shape s => SomeShape s
someShape :: Parser SomeShape
someShape = SomeShape <$> (parseShape :: Parser Circle)
<|> SomeShape <$> (parseShape :: Parser Rectangle)
type Raster = [[Char]]
render :: (Shape s) => Box -> (Int, Int) -> s -> Raster
render (Box (x1,y1) (x2,y2)) (cx,cy) s
= [[ if inShape (x,y) s then 'X' else ' '
| x <- [x1',x1'+delta..x2']] | y <- [y1',y1'-delta*caspect..y2']]
where caspect = 2 -- font character aspect ratio
expand = 1.2 -- expansion of raster beyond bounding box
delta = max ((x2-x1) / fromIntegral cx) ((y2-y1) / fromIntegral cy / caspect)
x1' = (x1+x2)/2 - expand*cx' * delta
x2' = (x1+x2)/2 + expand*cx' * delta
y1' = (y1+y2)/2 + expand*cy' * delta * caspect
y2' = (y1+y2)/2 - expand*cy' * delta * caspect
cx' = fromIntegral cx / 2
cy' = fromIntegral cy / 2
driver :: String -> IO ()
driver spec = do
putStrLn "---BEGIN---"
let res = parse (someShape <* eof) "(string)" spec
case res of
Left err -> error (errorBundlePretty err)
Right (SomeShape s) -> putStrLn $ unlines $ render (bbox s) (40,20) s
putStrLn "---END---"
main :: IO ()
main = do
driver "C(3,8)8" -- circle radius 8 centered at (3,8)
driver "R(-1,6)8,3" -- rectangle centered at (-1,6) w/ dim 8 by 3
There's not a tremendous amount of difference between this type class based version and the first ADT version above. Using a natural, common syntax, it's about 15% longer, as measured by lines or characters, it requires the use of an existential data type, and it includes some complex distractions related to that type.
Now, suppose we want to add an Octagon. The type class implementation should provide much cleaner extensibility for new shapes. We need to add the type and its instance:
data Octagon = Octagon Pos Scalar deriving (Show)
instance Shape Octagon where
parseShape = Octagon <$ char 'O' <*> pos <*> scalar
bbox (Octagon (x,y) w) = Box (x-w/2,y-w/2) (x+w/2,y+w/2)
inShape (x,y) (Octagon (cx,cy) w)
= cx-w/2 <= x && x <= cx+w/2
&& cy-w/2 <= y && y <= cy+w/2
&& abs (x-cx) + abs (y-cy) <= w / sqrt 2
Unfortunately, we need to separately add the octagon to the enumeration in the shape parser:
someShape :: Parser SomeShape
someShape = SomeShape <$> (parseShape :: Parser Circle)
<|> SomeShape <$> (parseShape :: Parser Rectangle)
<|> SomeShape <$> (parseShape :: Parser Octagon)
This seems like defect. We ought to specify a master list of shapes in one place that can be sequenced at runtime to iterate over all parseShape methods (as well as other methods we might later add that require similar enumeration). A straightforward way of doing this is to define a function that converts a generic Shape operation into a sequence of specialized operations across concrete shapes. That is:
overShapes :: (forall s. Shape s => Proxy s -> a) -> [a]
overShapes op =
[ op (Proxy #Circle)
, op (Proxy #Rectangle)
, op (Proxy #Octagon)]
Now we can write shape succintly as:
someShape :: Parser SomeShape
someShape = asum (overShapes op)
where op :: forall s. (Shape s) => Proxy s -> Parser SomeShape
op _ = SomeShape <$> parseShape #s
This should really pay off now that we're ready to add unions. We will only need to define a Union type and instance containing all the supporting functionality in one place and then remember to add it to overShapes for a seamless extension.
Unfortunately, the obvious definition:
data Union = Union Shape Shape deriving (Show)
doesn't work, since Shape is a type class. We might start with something like:
data Union s t = Union s t deriving (Show)
instance (Shape s, Shape t) => Shape (Union s t) where
parseShape = ...
bbox (Union s t)
= let Box (x1,y1) (x2,y2) = bbox s
Box (x3,y3) (x4,y4) = bbox t
in Box (min x1 x3, min y1 y3) (max x2 x4, max y2 y4)
inShape p (Union s t) = inShape p s || inShape p t
Now, when we try to define parseShape, we run into a bit of a problem. We can certainly define:
instance (Shape s, Shape t) => Shape (Union s t) where
parseShape = Union <$ char 'U' <*> parseShape <*> parseShape
but it quickly becomes apparent that we can't make any use of it. The parseShape parser can only parse a known shape, like Union Circle Rectangle. If we want to parse an arbitrary union, we need to parse its components not using parseShape but instead by using someShape and then constructing an existential SomeShape for the Union, which can't expose its subshapes in the Union type. So, we'll probably need to write:
data Union = Union SomeShape SomeShape
instance Shape Union where
parseShape = Union <$ char 'U' <*> someShape <*> someShape
bbox (Union (SomeShape s) (SomeShape t))
= let Box (x1,y1) (x2,y2) = bbox s
Box (x3,y3) (x4,y4) = bbox t
in Box (min x1 x3, min y1 y3) (max x2 x4, max y2 y4)
inShape p (Union (SomeShape s) (SomeShape t)) = inShape p s || inShape p t
As mentioned, we'll need to add it to the overShapes function:
overShapes op =
[ op (Proxy #Circle)
, op (Proxy #Rectangle)
, op (Proxy #Octagon)
, op (Proxy #Union)]
Still, it's nice that we were able to add the support for Union in one place plus the overShapes enumeration.
Unfortunately, when it comes time to add our description method, the extensbility is the wrong way around. Instead of defining description in one place, as we did with the ADT implementation, we need to add a type signature and method calls to all the classes (basically 5 lines in 5 places), just as we did when adding bbox and inShape during development.
The final program is 113 lines and 3961 characters, about 20-25% longer than the ADT version. It also contains some real stinkers like:
overShapes :: (forall s. Shape s => Proxy s -> a) -> [a]
and
op :: forall s. (Shape s) => Proxy s -> Parser SomeShape
op _ = SomeShape <$> parseShape #s
but at least we can conveniently extend it by adding 7 lines in 2 places instead of 5 lines in 5 places, as long as we're only adding a new shape and not adding functionality that requires a new method -- for that, we need to add 5 lines in 5 places instead of 5 lines in 1 place.
The final program:
{-# OPTIONS_GHC -Wall #-}
import Data.Proxy
import Control.Applicative (asum)
import Data.Void
import Text.Megaparsec hiding (Pos)
import Text.Megaparsec.Char
data Box = Box Pos Pos deriving (Show)
class Shape s where
parseShape :: Parser s
bbox :: s -> Box
inShape :: Pos -> s -> Bool
description :: s -> String
overShapes :: (forall s. Shape s => Proxy s -> a) -> [a]
overShapes op =
[ op (Proxy #Circle)
, op (Proxy #Rectangle)
, op (Proxy #Octagon)
, op (Proxy #Union)]
type Pos = (Float, Float)
type Scalar = Float
data Circle = Circle Pos Scalar deriving (Show)
instance Shape Circle where
parseShape = Circle <$ char 'C' <*> pos <*> scalar
bbox (Circle (x,y) r) = Box (x-r,y-r) (x+r,y+r)
inShape (x,y) (Circle (cx,cy) r) = sq (x-cx) + sq (y-cy) <= sq r
where sq a = a*a
description (Circle c r) = "a circle centered at " ++ show c ++ " with radius " ++ show r
data Rectangle = Rectangle Pos Scalar Scalar deriving (Show)
instance Shape Rectangle where
parseShape = Rectangle <$ char 'R' <*> pos <*> scalar <* char ',' <*> scalar
bbox (Rectangle (x,y) w h) = Box (x-w/2,y-h/2) (x+w/2,y+h/2)
inShape (x,y) (Rectangle (cx,cy) w h)
= cx-w/2 <= x && x <= cx+w/2
&& cy-h/2 <= y && y <= cy+h/2
description (Rectangle c w h) = "a rectangle centered at " ++ show c ++ " with width " ++ show w ++ " and height " ++ show h
data Octagon = Octagon Pos Scalar deriving (Show)
instance Shape Octagon where
parseShape = Octagon <$ char 'O' <*> pos <*> scalar
bbox (Octagon (x,y) w) = Box (x-w/2,y-w/2) (x+w/2,y+w/2)
inShape (x,y) (Octagon (cx,cy) w)
= cx-w/2 <= x && x <= cx+w/2
&& cy-w/2 <= y && y <= cy+w/2
&& abs (x-cx) + abs (y-cy) <= w / sqrt 2
description (Octagon c w) = "an octagon centered at " ++ show c ++ " with width " ++ show w
data Union = Union SomeShape SomeShape
instance Shape Union where
parseShape = Union <$ char 'U' <*> someShape <*> someShape
bbox (Union (SomeShape s) (SomeShape t))
= let Box (x1,y1) (x2,y2) = bbox s
Box (x3,y3) (x4,y4) = bbox t
in Box (min x1 x3, min y1 y3) (max x2 x4, max y2 y4)
inShape p (Union (SomeShape s) (SomeShape t)) = inShape p s || inShape p t
description (Union (SomeShape s) (SomeShape t)) = "the union of " ++ description s ++ " and " ++ description t
type Parser = Parsec Void String
pos :: Parser Pos
pos = (,) <$ char '(' <*> scalar <* char ',' <*> scalar <* char ')'
scalar :: Parser Scalar
scalar = do
sgn <- option 1 (-1 <$ char '-')
dig1 <- digits
dig2 <- option "" ((:) <$> char '.' <*> digits)
return $ sgn * read (dig1 ++ dig2)
where digits = some digitChar
data SomeShape = forall s. Shape s => SomeShape s
someShape :: Parser SomeShape
someShape = asum (overShapes op)
where op :: forall s. (Shape s) => Proxy s -> Parser SomeShape
op _ = SomeShape <$> parseShape #s
type Raster = [[Char]]
render :: (Shape s) => Box -> (Int, Int) -> s -> Raster
render (Box (x1,y1) (x2,y2)) (cx,cy) s
= [[ if inShape (x,y) s then 'X' else ' '
| x <- [x1',x1'+delta..x2']] | y <- [y1',y1'-delta*caspect..y2']]
where caspect = 2 -- font character aspect ratio
expand = 1.2 -- expansion of raster beyond bounding box
delta = max ((x2-x1) / fromIntegral cx) ((y2-y1) / fromIntegral cy / caspect)
x1' = (x1+x2)/2 - expand*cx' * delta
x2' = (x1+x2)/2 + expand*cx' * delta
y1' = (y1+y2)/2 + expand*cy' * delta * caspect
y2' = (y1+y2)/2 - expand*cy' * delta * caspect
cx' = fromIntegral cx / 2
cy' = fromIntegral cy / 2
driver :: String -> IO ()
driver spec = do
putStrLn "---BEGIN---"
let res = parse (someShape <* eof) "(string)" spec
case res of
Left err -> error (errorBundlePretty err)
Right (SomeShape s) -> do
putStrLn $ unlines $ render (bbox s) (40,20) s
putStrLn $ description s
putStrLn "---END---"
main :: IO ()
main = do
driver "UR(0,0)2,2UC(1,1)0.5C(-1,1)0.5"
Conclusions
The bottom line is that the ADT solution is straightforward to develop, understand, and extend. The type class solution pays a notable price in unnecessary complexity during development, in terms of both unusual type system features and the tendency to break the natural flow of development by splitting functions (which are the natural unit of development for functional programs) across separate instances, all for the promise of improved "extensibility" of the final program that is rarely realized in the real world.
I didn't time myself, but I'd estimate that my development time was about the same for each version. Considering that I wrote the ADT version first and copied and pasted everything I could from that to the type class version, this is quite an indictment of the type class version. The time I spent thinking through the core logic of the program (the overall design, the technical aspects of rendering the shapes, parsing a scalar in the most awkward way possible, etc.) plus the ADT implementation itself took about as much effort as thinking through the stupidities of the SomeShape type and fighting the Haskell type system to get the Union to work.
My larger experience with Haskell programming is that this is how it usually goes with ADT-based versus type-class-based designs, except it gets worse for bigger programs.
So we are trying to build a Pythagoras Tree using gloss, and it fails level 2 and next ones (only works level 0 and 1).
Here is the code:
data FTree a b = Unit b | Comp a (FTree a b) (FTree a b) deriving (Eq,Show)
type PTree = FTree Square Square
type Square = Float
generatePTree n = aux n 100 where
aux :: Int -> Float -> PTree
aux 0 x = Unit x
aux n x = Comp x (aux (n-1) (x * (sqrt(2)/2))) (aux (n-1) (x * (sqrt(2)/2)))
drawPTree :: PTree -> [Picture]
drawPTree p = aux p (0,0) 0 where
aux :: PTree -> (Float, Float) -> Float -> [Picture]
aux (Unit c) (x,y) ang = [Translate x y (Rotate ang (square c))]
aux (Comp c l r) (x,y) ang = [Translate x y (Rotate ang (square c))]++(aux l (x - somaX c,y + somaY c) (ang - 45)) ++ (aux r (x + somaX c,y + somaY c) (ang + 45))
where somaX c = c/2
somaY c = c + sqrt(((c * (sqrt 2))/4)^2 - ((sqrt (c^2 + c^2)) / 4)^2)
window = (InWindow "CP" (800,800) (0,0))
square s = rectangleSolid s s
main = animate window white draw
where
pics = drawPTree (generatePTree 2)
draw t = Pictures $ pics
The problem lies solely in your drawPTree function, and I'll address the problems I found in it, into a working solution.
We start with your current solution:
drawPTree :: PTree -> [Picture]
drawPTree p = aux p (0,0) 0 where
aux :: PTree -> (Float, Float) -> Float -> [Picture]
aux (Unit c) (x,y) ang = [Translate x y (Rotate ang (square c))]
aux (Comp c l r) (x,y) ang = [Translate x y (Rotate ang (square c))]++(aux l (x - somaX c,y + somaY c) (ang - 45)) ++ (aux r (x + somaX c,y + somaY c) (ang + 45))
where somaX c = c/2
somaY c = c + sqrt(((c * (sqrt 2))/4)^2 - ((sqrt (c^2 + c^2)) / 4)^2)
First up, let's deal with somaX and somaY, which based on the implementation are the translations to x and y along the direction of the current branch.
Note that you can define them as variables instead of functions, since c is already in scope, also, sqrt(((c * (sqrt 2))/4)^2 - ((sqrt (c^2 + c^2)) / 4)^2)=0 hence somaY = c (this can be seen from the diagram of Pythagoras Tree):
drawPTree :: PTree -> [Picture]
drawPTree p = aux p (0,0) 0 where
aux :: PTree -> (Float, Float) -> Float -> [Picture]
aux (Unit c) (x,y) ang = [Translate x y (Rotate ang (square c))]
aux (Comp c l r) (x,y) ang = [Translate x y (Rotate ang (square c))] ++
(aux l (x - somaX,y + somaY) (ang - 45)) ++
(aux r (x + somaX,y + somaY) (ang + 45))
where somaX = c/2
somaY = c
This code still won't give you the correct result, simply because Translate works on the global coordinate system, so we need to give it the correct points. Luckily we can easily get the correct transformation by simple trigonometry
drawPTree :: PTree -> [Picture]
drawPTree p = aux p (0,0) 0 where
aux :: PTree -> (Float, Float) -> Float -> [Picture]
aux (Unit c) (x,y) ang = [Translate x y (Rotate ang (square c))]
aux (Comp c l r) (x,y) ang = [Translate x y (Rotate ang (square c))] ++
(aux l (x + somaXLeft,y + somaYLeft) (ang - 45)) ++
(aux r (x + somaXRight,y + somaYRight) (ang + 45))
where somaX = c/2
somaY = c
angRads = ang * pi / 180
branchToGlobal angle (dx,dy) =
(dx * cos angle + dy * sin angle, dy * cos angle - dx * sin angle)
(somaXLeft, somaYLeft) = branchToGlobal angRads (-somaX, somaY)
(somaXRight, somaYRight) = branchToGlobal angRads (somaX, somaY)
And this will indeed render the tree correctly.
I'm trying to write a simulator for charged and massed objects based on just calculating the net force on each object then finding the change in position across the period of time specified by the user.
However, I'm finding that when I change the dt, the change in position is drastic, when it shouldn't change significantly, decreasing the dt should just let the position converge on the correct answer.
For instance, with objects at the Cartesian coordinates (1, 0, 0) and (-1, 0, 0), with masses of 9e-31 (mass of electron) and a charge of 1 Coulomb (not the charge of an electron, I know), run for 0.1 seconds and a dt of 0.01 seconds, there is a total change of position of 2048 meters for each object. However, run for 0.1 seconds and a dt of 0.001 seconds, there is a change in position of about 1.3e30 meters. This seems rather outrageous to me, but I can't find any issues in the parts that use dt.
The code I'm using (c/p'd to avoid any possible changes)
import Data.List
main = print $ mainprog
where
mainprog = runUniverse makeUniverse 1 0.1
type Length = Double
type Mass = Double
type Charge = Double
type Time = Double
type Vector = (Double, Double, Double)
type Position = Vector
type Velocity = Vector
type Acceleration = Vector
type Force = Vector
data Widget = Widget {pos :: Position, mass :: Double, charge :: Double, velocity :: Velocity} deriving (Eq, Show, Read)
--utils
toScalar :: Vector -> Double
toScalar (x, y, z) = sqrt (x ^^ 2 + y ^^ 2 + z ^^ 2)
toUnit :: Vector -> Vector
toUnit (x, y, z) = (x / scalar, y / scalar, z / scalar)
where
scalar = toScalar (x, y, z)
add :: Vector -> Vector -> Vector
add (x1, y1, z1) (x2, y2, z2) = (x1 + x2, y1 + y2, z1 + z2)
mult :: Vector -> Double -> Vector
mult (x, y, z) k = (k * x, k * y, k * z)
diff :: Vector -> Vector -> Vector
diff (x1, y1, z1) (x2, y2, z2) = (x1 - x2, y1 - y2, z1 - z2)
--calcs
gForce :: Widget -> Widget -> Force
gForce (Widget pos1 mass1 _ _) (Widget pos2 mass2 _ _) = mult unitForce scalarForce
where
unitForce = toUnit posdiff
scalarForce = (g * mass1 * mass2) / (radius ^^ 2)
g = 6.674e-11
radius = toScalar posdiff
posdiff = diff pos1 pos2
eForce :: Widget -> Widget -> Force
eForce (Widget pos1 _ charge1 _) (Widget pos2 _ charge2 _) = mult unitForce scalarForce
where
unitForce = (toUnit posdiff)
--necessary to determine attraction vs repulsion, whereas gravitational is always attractive
scalarForce = ((abs (k_C * charge1 * charge2)) / (radius ^^ 2)) * (signum charge1) * (signum charge2)
k_C = 8.988e9
radius = toScalar posdiff
posdiff = diff pos1 pos2
netForce :: [Force] -> Force
netForce = foldl add (0, 0, 0)
toAccel :: Force -> Widget -> Acceleration
toAccel f (Widget _ mass _ _) = mult f (1/mass)
newVeloc :: Velocity -> Acceleration -> Time -> Velocity
newVeloc v a dt = add v (mult a dt)
newPos :: Vector -> Velocity -> Time -> Vector
newPos s v dt = add s (mult v dt)
newWidget :: Widget -> Position -> Velocity -> Widget
newWidget (Widget pos1 mass charge vel1) pos2 vel2 = Widget pos2 mass charge vel2
tUniverse :: [Widget] -> Time -> [Widget]
tUniverse widgets dt = zipWith3 newWidget widgets poses vels
where
netMassForces = map (\w -> gForcePrime w (widgets \\ [w])) widgets
gForcePrime w ws = netForce $ map (gForce w) ws
netElectricForces = map (\w -> eForcePrime w (widgets \\ [w])) widgets
eForcePrime w ws = netForce $ map (eForce w) ws
volds = map velocity widgets
polds = map pos widgets
accels = zipWith toAccel (map netForce (zipWith (\a b -> a : [b]) netMassForces netElectricForces)) widgets
vels = zipWith (\v a -> newVeloc v a dt) volds accels
poses = zipWith (\s v -> newPos s v dt) polds vels
makeUniverse :: [Widget]
makeUniverse = [(Widget (-1, 0, 0) 1 1 (0, 0, 0)), (Widget (1, 0, 0) 1 1 (0, 0, 0))]
runUniverse :: [Widget] -> Time -> Time -> [Widget]
runUniverse ws t dt
| t <= 0 = ws
| otherwise = runUniverse (tUniverse (inelasticCollide ws) dt) (t-dt) dt
inelasticCollide :: [Widget] -> [Widget]
inelasticCollide [] = []
inelasticCollide (w:[]) = [w]
inelasticCollide (w:ws) = (combine w (sameposes w ws)) : (inelasticCollide $ ws \\ (sameposes w ws))
where
sameposes w ws = filter (\w' -> pos w == pos w') ws
combine :: Widget -> [Widget] -> Widget
combine = foldl (\(Widget pos mass1 charge1 veloc1) (Widget _ mass2 charge2 veloc2) -> Widget pos (charge1 + charge2) (mass1 + mass2) (newveloc mass1 mass2 veloc1 veloc2))
--inelastic collision, m1v1 + m2v2 = m3v3 therefore v3 = (m1v1 + m2v2)/(m1 + m2)
newveloc m1 m2 v1 v2 = ((v1 `mult` m1) `add` (v2 `mult` m2)) `mult` (1 / (m1 + m2))
The issue I know is in the tUniverse function, probably in some calculation of either acceleration, velocity, or position (accels, vels, or poses). I've tried changing toAccel, newVeloc, and newPos by multiplying each by the inverse of dt, but it didn't significantly change the outputs.
Feel free to ignore inelasticCollide, I could probably replace it with the id function, but I just left it in because it will be relevant at some point.
EDIT: I've updated the code to fix the incorrect calculation of acceleration, the switching of mass and charge in inelasticallyCollide, and the double counting with dpos/dvel, but I'm still finding that I'm getting an error of by a magnitude of 10. For instance, with a charge of 1 C for each, I got ~10^8 for dt = 0.01 and ~10^7 for dt = 0.1 and with a charge of 0.01 C for each, ~250 for dt = 0.01 and ~65 for dt = 0.1.
It seems the "obvious" issue is that newWidget assumes dpos and dvel are deltas, but when it's called in tUniverse poses and vels have actually already done the addition.
To debug I had rewritten things to use newtypes thinking that perhaps there was a mismatch somewhere. There did turn out to be an issue of masses and charges being transposed in inelasticCollide but that didn't matter for my test case. The way I found this issue was by adding the traces and seeing that the object's position component doubled each tick when the velocity component was 1.
I have no idea whether any calculations are accurate otherwise.
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Data.List
import Debug.Trace (trace)
main = print $ runUniverse makeUniverse 0.1 0.01
newtype Length = Length {unLength::Double}
newtype Mass = Mass {unMass::Double} deriving (Num,Eq,Show)
newtype Charge = Charge {unCharge::Double} deriving (Num,Eq,Show)
newtype Time = Time {unTime::Double} deriving (Num,Eq,Ord,Fractional)
type Vector = (Double,Double,Double)
newtype Position = Position {unPosition::Vector} deriving (Eq,Show)
newtype Velocity = Velocity {unVelocity::Vector} deriving (Eq,Show)
newtype Acceleration = Acceleration {unAcceleration::Vector}
newtype Force = Force {unForce::Vector} deriving (Eq,Show)
data Widget = Widget {pos :: Position, mass :: Mass, charge :: Charge, velocity :: Velocity} deriving (Eq, Show)
--utils
toScalar :: Vector -> Double
toScalar (x, y, z) = sqrt (x ^^ 2 + y ^^ 2 + z ^^ 2)
toUnit :: Vector -> Vector
toUnit (x, y, z) = (x / scalar, y / scalar, z / scalar)
where
scalar = toScalar (x, y, z)
add :: Vector -> Vector -> Vector
add (x1, y1, z1) (x2, y2, z2) = (x1 + x2, y1 + y2, z1 + z2)
mult :: Vector -> Double -> Vector
mult (x, y, z) k = (k * x, k * y, k * z)
diff :: Vector -> Vector -> Vector
diff (x1, y1, z1) (x2, y2, z2) = (x1 - x2, y1 - y2, z1 - z2)
--calcs
gForce :: Widget -> Widget -> Force
gForce (Widget (Position pos1) (Mass mass1) _ _) (Widget (Position pos2) (Mass mass2) _ _) = Force (mult unitForce scalarForce)
where
unitForce = toUnit posdiff
scalarForce = (g * mass1 * mass2) / (radius ^^ 2)
g = 6.674e-11
radius = toScalar posdiff
posdiff = diff pos1 pos2
eForce :: Widget -> Widget -> Force
eForce (Widget (Position pos1) _ (Charge charge1) _) (Widget (Position pos2) _ (Charge charge2) _) = Force (mult unitForce scalarForce)
where
unitForce = (toUnit posdiff)
--necessary to determine attraction vs repulsion, whereas gravitational is always attractive
scalarForce = ((abs (k_C * charge1 * charge2)) / (radius ^^ 2)) * (signum charge1) * (signum charge2)
k_C = 8.988e9
radius = toScalar posdiff
posdiff = diff pos1 pos2
netForce :: [Force] -> Force
netForce = Force . foldl add (0,0,0) . map unForce
toAccel :: Force -> Widget -> Acceleration
toAccel f (Widget _ mass _ _) = Acceleration (mult (unForce f) (unMass mass))
newVeloc :: Velocity -> Acceleration -> Time -> Velocity
newVeloc v a dt = Velocity (add (unVelocity v) (mult (unAcceleration a) (unTime dt)))
newPos :: Position -> Velocity -> Time -> Position
newPos s v dt = Position (add (unPosition s) (mult (unVelocity v) (unTime dt)))
newWidget :: Widget -> Position -> Velocity -> Widget
newWidget w#(Widget pos1 _ _ vel1) dpos dvel = w { pos=Position ((unPosition dpos)),velocity=Velocity ((unVelocity dvel)) }
tUniverse :: [Widget] -> Time -> [Widget]
tUniverse widgets dt = zipWith3 newWidget widgets (trace (show poses) poses) (trace (show vels) vels)
where
netMassForces = map (\w -> gForcePrime w (widgets \\ [w])) widgets
gForcePrime w ws = netForce $ map (gForce w) ws
netElectricForces = map (\w -> eForcePrime w (widgets \\ [w])) widgets
eForcePrime w ws = netForce $ map (eForce w) ws
volds = map velocity widgets
polds = map pos widgets
accels = zipWith toAccel (map netForce (zipWith (\a b -> a : [b]) netMassForces netElectricForces)) widgets
vels = zipWith (\v a -> newVeloc v a dt) volds accels
poses = zipWith (\s v -> newPos s v dt) polds vels
makeUniverse :: [Widget]
makeUniverse = [Widget (Position (1,0,0)) (Mass 0) (Charge 0) (Velocity (1,0,0))] -- , (Widget (1, 0, 0) 9e-31 1 (0, 0, 0))]
runUniverse :: [Widget] -> Time -> Time -> [Widget]
runUniverse ws t dt
| t < 0 = ws
| otherwise = runUniverse (tUniverse (inelasticCollide ws) dt) (t-dt) dt
inelasticCollide :: [Widget] -> [Widget]
inelasticCollide [] = []
inelasticCollide (w:[]) = [w]
inelasticCollide (w:ws) = (combine w (sameposes w ws)) : (inelasticCollide $ ws \\ (sameposes w ws))
where
sameposes w ws = filter (\w' -> pos w == pos w') ws
combine :: Widget -> [Widget] -> Widget
combine = foldl (\(Widget pos mass1 charge1 veloc1) (Widget _ mass2 charge2 veloc2) -> Widget pos (mass1 + mass2) (charge1 + charge2) (Velocity (newveloc (unMass mass1) (unMass mass2) (unVelocity veloc1) (unVelocity veloc2))))
--inelastic collision, m1v1 + m2v2 = m3v3 therefore v3 = (m1v1 + m2v2)/(m1 + m2)
newveloc m1 m2 v1 v2 = ((v1 `mult` m1) `add` (v2 `mult` m2)) `mult` (1 / (m1 + m2))