MFl*_*mer 6 haskell zipper algebraic-data-types
我有几个ADT代表Haskell中的一个简单的几何树.关于让我的操作类型与树结构分离的事情困扰着我.我正在考虑让Tree类型包含运算符的构造函数,它看起来似乎更干净.我看到的一个问题是我的Zipper实现必须改变以反映所有这些新的可能的构造函数.有没有办法解决？还是我错过了一些重要的概念？总的来说,我觉得我无法掌握如何在Haskell中一般构建我的程序.我理解大多数概念,ADT,类型类,monad,但我还不了解大局.谢谢.
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)
这可能不会触及您 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''