6

Haskellの単純なジオメトリツリーを表すADTがいくつかあります。私の操作タイプをツリー構造から分離することについての何かが私を悩ませています。Tree型に演算子のコンストラクターを含めることを考えていますが、よりクリーンなようです。これに関して私が目にする問題の1つは、これらの新しい可能なコンストラクターをすべて反映するために、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

圏論に触発され、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

しかし、それはあなたが書いたものの正確な翻訳であり、無料のモナドでできるすべてのクールなことを完全に無視しています。たとえば、すべての無料のモナドは無料のモナドです。つまり、do表記を使用して実際にジオメトリツリーを構築できます。たとえば、変換関数を書き直して、2番目のパラメーターをまったく受け取らないようにし、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

次に、関数の戻り値を調べて、左または右のブランチで操作しているかどうかを確認します。これは、 s関数unionの戻り値を調べて、親または子として続行するかどうかを確認するのと同じ方法です。Cfork

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 に答える
2

これは、API 設計に関する問題の核心には到達しないかもしれませんが、いくつかのアイデアが得られるかもしれません。

lensに基づいた 2 つの汎用ジッパー ライブラリを作成しました。レンズは型の「分解/再構築」をカプセル化し、コンテキスト内の内部値のビューを提供します。これにより、データ型の特定のフィールドなどの「取得」と「設定」が可能になります。ジッパーのこの一般的な処方は、より口当たりが良いと感じるかもしれません。

それが興味深いと思われる場合は、注目すべきライブラリはzippoです。これは非常に小さなライブラリですが、エキゾチックな要素がいくつか含まれているため、ここの簡単なチュートリアルに興味があるかもしれません。

良い点: ジッパーは異種であり、さまざまなタイプを「下に移動」できます (たとえばradius、 a のに焦点を当てたり、まだ考えていなかったSphere新しい再帰的なタイプを下に移動したりできます)。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''
于 2012-08-22T15:38:55.003 に答える