堆栈内存溢出
  繁体   English   中英

Haskell 中的临时多态性与数据构造函数

[英]Ad-hoc Polymorphism vs. Data Constructors in Haskell

 原文  2023-01-28 11:57:09  3   2    haskell/ polymorphism/ adt/ typeclass

问题描述

为一个类型定义不同的数据构造函数，然后使用模式匹配定义函数，这与其他语言中的临时多态性非常相似：

data Shape = Circle Float | Rectangle Float Float
area :: Shape -> Float
area (Circle r) = pi * r^2
area (Rectangle a b) = a*b

使用你可以做的类型类

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

我看到的第二个优点之一是它可以在不触及现有声明的情况下进行扩展，特别是它可能是您唯一的选择。 是否有其他理由更喜欢其中之一？

2 个解决方案

解决方案1
 3  2023-01-28 23:05:45

要使第二种方法起作用，您必须在编译时知道类型，而使用s一种方法可以匹配运行时值

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

类型 Class 和代数数据类型之间的区别

Scala：类型类和 ADT 之间的区别？

类型类与代数数据类型？

解决方案2
 2  2023-01-28 23:13:59

要比较这些方法，了解数据类型声明之外的内容会有所帮助。

假设我们要编写一个 Haskell 程序来解析一个形状规范并将其显示为屏幕上的 ASCII 图。

解决方案 #1

一种方法是将我们的Shape定义为 ADT：

type Pos = (Float, Float)
type Scalar = Float

data Shape
  = Circle Pos Scalar
  | Rectangle Pos Scalar Scalar
  deriving (Show)

为了解析规范，我们将使用 Megaparsec。 这将需要一个Parser Shape ：

shape :: Parser Shape
shape = Circle <$ char 'C' <*> pos <*> scalar
    <|> Rectangle <$ char 'R' <*> pos <*> scalar <* char ',' <*> scalar

加上一些额外的pos和scalar解析器（见下文）。

要渲染形状，我们首先要计算它的边界框：

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 --- ugly computations of x1', etc. go here

这依赖于 function 可以确定光栅点是否在形状内部：

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

添加一些驱动程序/主要功能并填写详细信息后，完整程序为：

{-# 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

它工作正常：

λ> 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---

假设我们要添加一个形状，如Octagon 。 这需要添加一个Octagon构造函数：

data Shape
  = ...
  | Octagon 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

我们必须自己弄清楚解析器需要修改：

shape = ...
    <|> Octagon   <$ char 'O' <*> pos <*> scalar

此更改需要在源代码的 4 个位置添加 7 行代码。

假设我们现在想要添加一种能力来创建由其他形状的并集组成的形状。 这个改动和scope类似，需要在4个位置增加7行代码。

最后，假设我们想要添加“呈现”为描述性文本格式的能力。 这需要在一个位置定义一个5行的function：

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

完整的程序如下。 它是 94 行和 3148 个字符的源代码，除了解析器的应用语法外，它没有使用高级 Haskell 功能。

{-# 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"

解决方案#2

编写该程序的第二种方法是定义一个Shape class 和代表每个可能形状的这个 class 实例的集合。 我们可能会指定我们想要支持的形状如下，但还没有定义任何功能：

class Shape s

data Circle = Circle Pos Scalar deriving (Show)
instance Shape Circle

data Rectangle = Rectangle Pos Scalar Scalar deriving (Show)
instance Shape Rectangle

现在，为了解析形状规范，我们将使用 Megaparsec。 我们不能编写Parser Shape ，因为Shape是一个类型 class。但是我们可以编写一个方法来解析各个形状。 这涉及向 class 和实例添加行：

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

我们可以通过定义存在类型来方便地解析任意形状：

data SomeShape = forall s. Shape s => SomeShape s

尽管看起来很诱人，但以下根本不起作用：

someShape :: Parser SomeShape
someShape = SomeShape <$> parseShape

不幸的是，没有办法避免像这样枚举单个形状：

someShape :: Parser SomeShape
someShape = SomeShape <$> (parseShape :: Parser Circle)
        <|> SomeShape <$> (parseShape :: Parser Rectangle)

现在我们可以解析形状了，我们要计算一个边界框。 这涉及将Box类型和三行 bbox 定义添加到bbox和两个实例：

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)

渲染 function 与之前的大致相同，除了它的类型签名：

render :: (Shape s) => Box -> (Int, Int) -> s -> Raster

render function 需要一个inShape方法，该方法涉及将inShape定义的三行添加到 class 和两个实例。

需要修改驱动程序以处理存在的形状。 在这种情况下，修复很简单——只需在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---"

完整程序如下：

{-# 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

这种基于 class 的版本与上面的第一个 ADT 版本之间没有太大区别。 使用自然、通用的语法，按行或字符计算，它长了大约 15%，它需要使用存在的数据类型，并且它包含一些与该类型相关的复杂干扰。

现在，假设我们要添加一个Octagon 。 class 类型的实现应该为新形状提供更清晰的可扩展性。 我们需要添加类型及其实例：

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

不幸的是，我们需要单独将八边形添加到shape解析器的枚举中：

someShape :: Parser SomeShape
someShape = SomeShape <$> (parseShape :: Parser Circle)
        <|> SomeShape <$> (parseShape :: Parser Rectangle)
        <|> SomeShape <$> (parseShape :: Parser Octagon)

这似乎是缺陷。 我们应该在一个地方指定一个形状的主列表，可以在运行时对其进行排序，以迭代所有parseShape方法（以及我们稍后可能添加的需要类似枚举的其他方法）。 一种直接的方法是定义一个 function，它将通用Shape操作转换为一系列具体形状的专用操作。 那是：

overShapes :: (forall s. Shape s => Proxy s -> a) -> [a]
overShapes op =
  [ op (Proxy @Circle)
  , op (Proxy @Rectangle)
  , op (Proxy @Octagon)]

现在我们可以将shape简洁地写成：

someShape :: Parser SomeShape
someShape = asum (overShapes op)
  where op :: forall s. (Shape s) => Proxy s -> Parser SomeShape
        op _ = SomeShape <$> parseShape @s

既然我们已准备好添加联合，这应该真正得到回报。 我们只需要在一个地方定义一个包含所有支持功能的Union类型和实例，然后记得将它添加到overShapes以实现无缝扩展。

不幸的是，显而易见的定义：

data Union = Union Shape Shape deriving (Show)

不起作用，因为Shape是 class 类型。我们可以从以下内容开始：

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

现在，当我们尝试定义parseShape时，我们遇到了一些问题。 我们当然可以定义：

instance (Shape s, Shape t) => Shape (Union s t) where
  parseShape = Union <$ char 'U' <*> parseShape <*> parseShape

但很快就会发现我们无法使用它。 parseShape解析器只能解析一个已知的形状，比如Union Circle Rectangle 。 如果我们想解析一个任意联合，我们需要不使用parseShape而是使用someShape来解析它的组件，然后为Union构造一个存在的SomeShape ，它不能在Union类型中公开它的子形状。 所以，我们可能需要这样写：

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

如前所述，我们需要将它添加到overShapes function：

overShapes op =
  [ op (Proxy @Circle)
  , op (Proxy @Rectangle)
  , op (Proxy @Octagon)
  , op (Proxy @Union)]

不过，很高兴我们能够在一个地方添加对Union的支持以及overShapes枚举。

不幸的是，当需要添加我们的description方法时，可扩展性是错误的。 不像我们在 ADT 实现中那样在一个地方定义description ，我们需要为所有类添加类型签名和方法调用（基本上 5 行在 5 个地方），就像我们在开发过程中添加bbox和inShape时所做的那样.

最终程序为 113 行和 3961 个字符，比 ADT 版本长约 20-25%。 它还包含一些真正的臭味，例如：

overShapes :: (forall s. Shape s => Proxy s -> a) -> [a]

和

op :: forall s. (Shape s) => Proxy s -> Parser SomeShape
op _ = SomeShape <$> parseShape @s

但至少我们可以通过在 2 个位置添加 7 行而不是在 5 个位置添加 5 行来方便地扩展它，只要我们只添加一个新形状而不是添加需要新方法的功能——为此，我们需要在 5 个地方添加 5 行，而不是在 1 个地方添加 5 行。

最终程序：

{-# 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"

结论

底线是 ADT 解决方案易于开发、理解和扩展。 类型 class 解决方案在开发过程中付出了不必要的复杂性的显着代价，包括不寻常的类型系统特性和通过在不同实例中拆分函数（这是函数程序的自然开发单元）来打破自然开发流程的趋势, 都是为了 promise 改进的最终程序的“可扩展性”，这在现实世界中很少实现。

我自己没有计时，但我估计每个版本的开发时间都差不多。 考虑到我首先编写了 ADT 版本，然后将我能复制的所有内容复制并粘贴到 class 版本，这完全是对 class 版本的控诉。 我花在思考程序的核心逻辑上的时间（总体设计、渲染形状的技术方面、以最尴尬的方式解析标量等）加上ADT 实现本身花费的精力与思考一样多通过SomeShape类型的愚蠢和与 Haskell 类型系统的斗争让Union工作。

我对 Haskell 编程的更大经验是，这通常是基于 ADT 与基于类型类的设计的方式，除了对于更大的程序它会变得更糟。

暂无
暂无

声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

相关问题 参数多态性 vs Ad-hoc 多态性 Haskell中的复杂即席多态性 Haskell ad-hoc多态性值，计算ad-hoc多态性列表的长度 如何在Haskell（即席多态）中重载用于乘以[Double]的函数？ 在Haskell中实现临时多态性的最佳方法？ Haskell中的通用编程，具有SYB和ad-hoc多态性 消除临时多态性 Haskell ad hoc多态性 Haskell的特别小团体 如何在Haskell中创建“kind类”，或者使用类型族在类型级创建ad-hoc多态
相关标签
 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM