適用於ADT的Haskell Zipper，具有許多構造函數

Question

我有幾個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)

Answer 1

這可能無法解決您的API設計問題的核心，但可能會給您一些想法。

我寫了兩個基於鏡頭的通用拉鏈庫。 鏡頭封裝了類型的“解構/重構”，使您可以在上下文中查看內部值，從而允許“獲取”和“設置”例如數據類型中的特定字段。 您可能會發現拉鏈的這種通用配方更加可口。

如果這聽起來很有趣你應該看的庫是zippo 。 它是一個非常小的lib，但有一些奇特的位，所以你可能會對這里的簡短演練感興趣。

好東西 ：拉鏈是異質的 ，允許你通過不同的類型“向下移動”（例如，你可以將焦點放在Sphere的radius上，或者通過一些你尚未想到的新的遞歸Primitive類型）。 此類型檢查器將確保您的“向上移動”永遠不會將您發送到結構的頂部; 唯一Maybe需要的地方是通過總和類型“向下”移動。

不太好的事情：我目前在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''

Answer 2

我建議學習免費monad ，它受類別理論的啟發，構成了在Haskell中構建抽象語法樹的慣用方法。 自由monad實現了兩個世界中最好的，因為樹是通過任何可能的函子抽象的，並且您通過定義提供給free monad的仿函數來定義抽象語法樹支持的操作集。

在你的情況下，你會寫：

{-# 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' :: Proj4 -> Geometry ()
transform' m = liftF $ Transform m ()

然后你可以使用普通的符號來編寫轉換：

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

你也可以寫，而不是像你的分支工作union和intersect在代碼叉

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

然后你只需要檢查union函數的返回值，看看你是在左邊還是右邊的分支上操作，就像檢查C s 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 notation，但它仍會生成一個普通的幾何樹，就像您手動構建它一樣。 此外，您可以選擇不使用do notation並仍然手動構建它。 該do記號只是一個很酷的獎金特點。