具有多个构造函数的Haskell Zipper for ADT

Question

在Haskell中，我有几个表示简单几何树的ADT。将我的操作类型从树结构中分离出来的问题让我很困扰。我在考虑让Tree类型包含运算符的构造函数，这样看起来会更干净。我看到的一个问题是，我的Zipper实现必须进行更改，以反映所有这些新的可能构造函数。有什么办法可以解决这个问题吗？或者我错过了一些重要的概念？总的来说，我觉得在Haskell中我很难掌握如何组织我的程序。我理解大多数的概念，ADT，类型类，monads，但我还不了解大局。谢谢。

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)

Answer 1

我已经编写了两个基于lenses的通用zipper库。镜头封装了一种类型的“解构/重构”，让你可以看到上下文中的内部值，这允许“获取”和“设置”数据类型中的特定字段。你可能会发现这个拉链的一般配方更容易让人接受。

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

the some ：拉链是异构的，允许你在不同的类型中“下移”(例如，你可以将你的注意力放在Sphere的radius上，或者通过一些你还没有想过的新的递归Primitive类型)。此外，类型检查器将确保您的“上移”不会使您超过结构的顶部；唯一需要Maybe的地方是通过sum类型进行“下移”。

自从我写了这个东西以来，镜片库的格局已经发生了很大的变化，所以当我有机会看到新的热点或更新后的旧热点时，我可能会过渡到使用埃克梅特的一个。

代码

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

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

Answer 2

我建议学习free monads，它受到范畴理论的启发，构成了在Haskell中构建抽象语法树的惯用方法。自由monad实现了这两个领域的最佳效果，因为树在任何可能的functor上都是抽象的，您可以通过定义提供给Free monad的functor来定义抽象语法树支持的一组操作。

在您的示例中，您可以这样写：

{-# 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 notation构建几何树。例如，您可以重写您的transform函数，使其根本不接受第二个参数，并让do表示法隐式提供它：

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

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

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

您也可以在代码中将分支操作(如union和intersect )编写为fork

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

然后，您只需检查union函数的返回值，以查看是否在左分支或右分支上操作，这与检查C的fork函数的返回值以查看您是否继续作为父分支或子分支的方式非常相似：

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符号只是一个很酷的额外特性。