6

我有一些 ADT 代表 Haskell 中的简单几何树。将我的操作类型与树形结构分开的事情让我很困扰。我正在考虑让 Tree 类型包含运算符的构造函数，看起来它会更干净。我看到的一个问题是我的 Zipper 实现必须改变以反映所有这些新的可能的构造函数。有没有办法解决？还是我错过了一些重要的概念？总的来说，我觉得我很难掌握如何在 Haskell 中构建我的程序。我了解大多数概念、ADT、类型类、单子，但我还不了解大局。谢谢。

module FRep.Tree
   (Tree(‥)
   ,Primitive(‥)
   ,UnaryOp(‥)
   ,BinaryOp(‥)
   ,TernaryOp(‥)
   ,sphere
   ,block
   ,transform
   ,union
   ,intersect
   ,subtract
   ,eval
   ) where



import Data.Vect.Double
--import qualified Data.Foldable as F
import Prelude hiding (subtract)
--import Data.Monoid


data Tree = Leaf    Primitive
          | Unary   UnaryOp   Tree
          | Binary  BinaryOp  Tree Tree
          | Ternary TernaryOp Tree Tree Tree
          deriving (Show)

sphere ∷  Double → Tree
sphere a = Leaf (Sphere a)

block ∷  Vec3 → Tree
block v = Leaf (Block v)

transform ∷  Proj4 → Tree → Tree
transform m t1 = Unary (Transform m) t1

union ∷  Tree → Tree → Tree
union t1 t2 = Binary Union t1 t2

intersect ∷  Tree → Tree → Tree
intersect t1 t2 = Binary Intersect t1 t2

subtract ∷  Tree → Tree → Tree
subtract t1 t2 = Binary Subtract t1 t2


data Primitive = Sphere { radius ∷  Double }
               | Block  { size   ∷  Vec3   }
               | Cone   { radius ∷  Double
                        , height ∷  Double }
               deriving (Show)


data UnaryOp = Transform Proj4
             deriving (Show)

data BinaryOp = Union
              | Intersect
              | Subtract
              deriving (Show)

data TernaryOp = Blend Double Double Double
               deriving (Show)


primitive ∷  Primitive → Vec3 → Double
primitive (Sphere r) (Vec3 x y z) = r - sqrt (x*x + y*y + z*z)
primitive (Block (Vec3 w h d)) (Vec3 x y z) = maximum [inRange w x, inRange h y, inRange d z]
   where inRange a b = abs b - a/2.0
primitive (Cone r h) (Vec3 x y z) = undefined





unaryOp ∷  UnaryOp → Vec3 → Vec3
unaryOp (Transform m) v = trim (v' .* (fromProjective (inverse m)))
   where v' = extendWith 1 v ∷  Vec4


binaryOp ∷  BinaryOp → Double → Double → Double
binaryOp Union f1 f2     = f1 + f2 + sqrt (f1*f1 + f2*f2)
binaryOp Intersect f1 f2 = f1 + f2 - sqrt (f1*f1 + f2*f2)
binaryOp Subtract f1 f2  = binaryOp Intersect f1 (negate f2)


ternaryOp ∷  TernaryOp → Double → Double → Double → Double
ternaryOp (Blend a b c) f1 f2 f3 = undefined


eval ∷  Tree → Vec3 → Double
eval (Leaf a) v             = primitive a v
eval (Unary a t) v          = eval t (unaryOp a v)
eval (Binary a t1 t2) v     = binaryOp a (eval t1 v) (eval t2 v)
eval (Ternary a t1 t2 t3) v = ternaryOp a (eval t1 v) (eval t2 v) (eval t3 v)


--Here's the Zipper--------------------------


module FRep.Tree.Zipper
   (Zipper
   ,down
   ,up
   ,left
   ,right
   ,fromZipper
   ,toZipper
   ,getFocus
   ,setFocus
   ) where


import FRep.Tree



type Zipper = (Tree, Context)

data Context = Root
             | Unary1   UnaryOp   Context
             | Binary1  BinaryOp  Context Tree
             | Binary2  BinaryOp  Tree    Context
             | Ternary1 TernaryOp Context Tree    Tree
             | Ternary2 TernaryOp Tree    Context Tree
             | Ternary3 TernaryOp Tree    Tree    Context


down ∷  Zipper → Maybe (Zipper)
down (Leaf p, c)             = Nothing
down (Unary o t1, c)         = Just (t1, Unary1 o c)
down (Binary o t1 t2, c)     = Just (t1, Binary1 o c t2)
down (Ternary o t1 t2 t3, c) = Just (t1, Ternary1 o c t2 t3)


up ∷  Zipper → Maybe (Zipper)
up (t1, Root)               = Nothing
up (t1, Unary1 o c)         = Just (Unary o t1, c)
up (t1, Binary1 o c t2)     = Just (Binary o t1 t2, c)
up (t2, Binary2 o t1 c)     = Just (Binary o t1 t2, c)
up (t1, Ternary1 o c t2 t3) = Just (Ternary o t1 t2 t3, c)
up (t2, Ternary2 o t1 c t3) = Just (Ternary o t1 t2 t3, c)
up (t3, Ternary3 o t1 t2 c) = Just (Ternary o t1 t2 t3, c)


left ∷  Zipper → Maybe (Zipper)
left (t1, Root)               = Nothing
left (t1, Unary1 o c)         = Nothing
left (t1, Binary1 o c t2)     = Nothing
left (t2, Binary2 o t1 c)     = Just (t1, Binary1 o c t2)
left (t1, Ternary1 o c t2 t3) = Nothing
left (t2, Ternary2 o t1 c t3) = Just (t1, Ternary1 o c t2 t3)
left (t3, Ternary3 o t1 t2 c) = Just (t2, Ternary2 o t1 c t3)


right ∷  Zipper → Maybe (Zipper)
right (t1, Root)               = Nothing
right (t1, Unary1 o c)         = Nothing
right (t1, Binary1 o c t2)     = Just (t2, Binary2 o t1 c)
right (t2, Binary2 o t1 c)     = Nothing
right (t1, Ternary1 o c t2 t3) = Just (t2, Ternary2 o t1 c t3)
right (t2, Ternary2 o t1 c t3) = Just (t3, Ternary3 o t1 t2 c)
right (t3, Ternary3 o t1 t2 c) = Nothing


fromZipper ∷  Zipper → Tree
fromZipper z = f z where
   f ∷  Zipper → Tree
   f (t1, Root)               = t1
   f (t1, Unary1 o c)         = f (Unary o t1, c)
   f (t1, Binary1 o c t2)     = f (Binary o t1 t2, c)
   f (t2, Binary2 o t1 c)     = f (Binary o t1 t2, c)
   f (t1, Ternary1 o c t2 t3) = f (Ternary o t1 t2 t3, c)
   f (t2, Ternary2 o t1 c t3) = f (Ternary o t1 t2 t3, c)
   f (t3, Ternary3 o t1 t2 c) = f (Ternary o t1 t2 t3, c)


toZipper ∷  Tree → Zipper
toZipper t = (t, Root)


getFocus ∷  Zipper → Tree
getFocus (t, _) = t


setFocus ∷  Tree → Zipper → Zipper
setFocus t (_, c) = (t, c)
4

2 回答 2

2

这可能不会触及您 API 设计问题的核心，但可能会给您一些想法。

我已经编写了两个基于lens的通用拉链库。镜头封装了一种类型的“解构/重组”，让您可以查看上下文中的内部值，这允许“获取”和“设置”例如数据类型中的特定字段。您可能会发现这种通用的拉链配方更可口。

如果这听起来很有趣，那么您应该查看的库是zippo。这是一个非常小的库，但有一些奇特的部分，所以你可能会对这里的简短演练感兴趣。

好东西：拉链是异构的，允许您“向下移动”不同类型（例如，您可以将注意力放在radiusa上，或者向下通过一些您还没有想到的Sphere新递归类型）。Primitive此外，类型检查器将确保您的“向上移动”永远不会让您越过结构的顶部；唯一需要的地方Maybe是通过 sum 类型“向下”移动。

不太好的事情：我目前正在使用我自己的镜头库，zippo并且还不支持自动派生镜头。所以在一个理想的世界里，你不会用手写镜头，所以当你的Tree类型改变时，你也不必改变任何东西。自从我写这个东西以来，镜头库的格局发生了很大变化，所以当我有机会看到新的热点或更新的旧热点时，我可能会过渡到使用 ekmett 的一个。

代码

如果这不是类型检查，请原谅我：

import Data.Lens.Zipper
import Data.Yall

-- lenses on your tree, ideally these would be derived automatically from record 
-- names you provided
primitive :: Tree :~> Primitive
primitive = lensM g s
    where g (Leaf p) = Just p
          g _ = Nothing
          s (Leaf p) = Just Leaf
          s _ = Nothing

unaryOp :: Tree :~> UnaryOp
unaryOp = undefined -- same idea as above

tree1 :: Tree :~> Tree
tree1 = lensM g s where
    g (Unary _ t1) = Just t1
    g (Binary _ t1 _) = Just t1
    g (Ternary _ t1 _ _) = Just t1
    g _ = Nothing
    s (Unary o _) = Just (Unary o)
    s (Binary o _ t2) = Just (\t1-> Binary o t1 t2)
    s (Ternary o _ t2 t3) = Just (\t1-> Ternary o t1 t2 t3)
    s _ = Nothing
-- ...etc.

然后使用拉链可能看起来像：

t :: Tree
t = Binary Union (Leaf (Sphere 2)) (Leaf (Sphere 3))

z :: Zipper Top Tree
z = zipper t

-- stupid example that only succeeds on focus shaped like 't', but you can pass a 
-- zippered structure of any depth
incrementSpheresThenReduce :: Zipper n Tree -> Maybe (Zipper n Tree)
incrementSpheresThenReduce z = do
    z1 <- move (radiusL . primitive . tree1) z
    let z' = moveUp $ modf (+1) z1
    z2 <- move (radiusL . primitive . tree2) z'
    let z'' = moveUp $ modf (+1) z2
    return $ modf (Leaf . performOp) z''
于 2012-08-22T15:38:55.003 回答
2

我建议学习免费的 monad，它受到范畴论的启发，构成了在 Haskell 中构建抽象语法树的惯用方式。自由单子实现了两全其美，因为树被抽象在任何可能的函子上，并且您通过定义提供给自由单子的函子来定义抽象语法树支持的操作集。

在你的情况下，你会写：

{-# LANGUAGE DeriveFunctor, UnicodeSyntax #-}

import Control.Monad.Free -- from the 'free' package

data GeometryF t
  = Sphere Double
  | Block Vec3
  | Transform Proj4 t
  | Union t t
  | Intersect t t
  | Subtract t t
  deriving (Functor)

type Vec3 = Int -- just so it compiles
type Proj4 = Int

type Geometry = Free GeometryF

sphere ∷  Double → Geometry a
sphere x = liftF $ Sphere x

block ∷  Vec3 → Geometry a
block v = liftF $ Block v

transform ∷  Proj4 → Geometry a -> Geometry a
transform m t = Free $ Transform m t

union ∷  Geometry a -> Geometry a -> Geometry a
union t1 t2 = Free $ Union t1 t2

intersect ∷  Geometry a -> Geometry a -> Geometry a
intersect t1 t2 = Free $ Intersect t1 t2

subtract ∷  Geometry a -> Geometry a -> Geometry a
subtract t1 t2 = Free $ Subtract t1 t2

但是，这只是对您所写内容的精确翻译，完全忽略了您可以使用免费 monad 做的所有很酷的事情。例如，每个免费的 monad 都是免费的 monad，这意味着我们实际上可以使用 do 表示法构建几何树。例如，您可以重写您的转换函数以完全不采用第二个参数，并让 do 表示法隐式提供它：

transform' :: Proj4 -> Geometry ()
transform' m = liftF $ Transform m ()

然后您可以使用普通的 do 表示法编写转换：

transformation :: Geometry ()
transformation = do
    transform m1
    transform m2
    transform m3

您也可以改为在代码中编写分支操作，例如union和分支intersect

union :: Geometry Bool
union = liftF $ Union False True

然后你只需检查union函数的返回值，看看你是在左分支还是右分支上操作，就像你检查Csfork函数的返回值以查看你是作为父还是子继续的方式：

branchRight :: Geometry a
branchLeft :: Geometry a

someUnion :: Geometry a
someUnion = do
    bool <- union
    if bool
    then do
        -- We are on the right branch
        branchRight
    else do
        -- We are on the left branch
        branchLeft

请注意，尽管您使用的是do符号，但它仍然会生成一个普通的几何树，就好像您是手工构建的一样。此外，您可以选择根本不使用do符号并仍然手动构建它。do符号只是一个很酷的奖励功能。

于 2012-08-22T17:26:23.867 回答