Haskell Zipper for ADT with many constructors

Question

I have a few ADT's that represent a simple geometry tree in Haskell. Something about having my operation types separate from the tree structure is bothering me. I'm thinking of making the Tree type contain constructors for the operators,it just seems like it would be cleaner. One problem I see with this is that my Zipper implementation will have to change to reflect all these new possible constructors. Is there any way around this? Or am I missing some important concept? In general I feel like I'm having trouble getting a grip on how to generally structure my programs in Haskell. I understand most of the concepts, ADT's, type classes, monads, but I'm not understanding the big picture yet. Thanks.

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)

Skinhead

It would be much better if you'd provide a code sample that works. – Emmettemmey

Indeed, unicode characters like ∷ instead :: and missing datatypes makes it complicated to do anything with that. Could you provide a code sample that can be compiled right away? – Sian

Just add {-# LANGUAGE UnicodeSyntax #-} or search-replace the operators... – Hardee

I wasn't complaining about the unicode syntax so much as about the presence of bla bla bla or undefined operations such as unaryOp. If I'm going to produce an example based on this code, it's much less work if I can just copy-paste and it works. – Emmettemmey

Answer 1

This might not get to the core of your API design concerns, but maybe gives you some ideas.

I've written two generic zipper libraries based on lenses. Lenses encapsulate a "destructuring / restructuring" of a type, giving you a view on an inner value in context, which allows "getting" and "setting" of e.g. specific fields in a datatype. You might find this general formulation of zippers to be more palatable.

If that sounds interesting the library you should look at is zippo. It's a very small lib but has some exotic bits, so you might be interested in the brief walkthrough here.

The nice things: the zipper is heterogenous, allowing you to "move down" through different types (e.g. you can land your focus on the radius of a Sphere, or down through some new recursive Primitive type you haven't thought of yet). Also the type checker will make sure your "move up"s never send you past the top of your structure; the only places where Maybe is necessary are moving "down" through a sum type.

The less nice thing: I'm currently using my own lens lib in zippo and don't have support for deriving lenses automatically yet. So in an ideal world you wouldn't be writing lenses by hand, so wouldn't have to change anything when your Tree type changes. The landscape of lens libraries has changed significantly since I wrote the thing, so I may transition to using one of ekmett's when I get a chance to look at the new hotness or updated old hotness.

Code

Forgive me if this doesn't type check:

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.

Then using the zipper might look something like:

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

Woothen

Thanks. I have heard mention of lenses, but have not read up on them yet. I will study this code a little and then possibly ask another question or 2. – Skinhead

Great! Also I apologize my example code could have been better in light of specifics from your recent edit. – Woothen

Answer 2

I suggest learning about free monads, which are inspired by category theory and constitute the idiomatic way to build abstract syntax trees in Haskell. Free monads accomplish the best of both worlds in that the tree is abstracted over any possible functor, and you define the set of operations the abstract syntax tree supports by defining the functor you supply to the free monad.

In your case, you would write:

{-# 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

However, that's just an exact translation of what you wrote and completely ignores all the cool things you can do with a free monad. For example, every free monad is a monad for free, meaning we could actually build the geometry tree using do notation. For example, you could rewrite your transform function to not take the second parameter at all and have the do notation implicitly supply it:

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

Then you could write transformations using ordinary do notation:

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

You could also instead write your branching operations like union and intersect as forks in the code

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

Then you just inspect the return value of the union function to see if you are operating on the left or right branch, much like the way you would inspect the return value of Cs fork function to see whether you continue as the parent or child:

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

Note that although you are using do notation, it still generates an ordinary geometry tree, as if you had built it by hand. Also, you can choose to not use do notation at all and still build it by hand. The do notation is just a cool bonus feature.

Onlybegotten

Thank you very much. Excellent responses like this really motivate a guy to keep learning. I'll have to spend a little time processing this. – Skinhead

What is the advantage of writing the branching operations like forks in the code as you suggest? I do like the option of using do notation though. Also, how does this effect the use of zippers on this structure? Excuse me if its obvious. – Skinhead

The branching operators are merely a cool trick to show the extreme case where you go all the way and use only do notation to build the tree. However you can mix and match ordinary construction and do notation or not use do notation at all. Also, zippers work just fine. The do notation just creates an ordinary tree as if you had written it by hand, so whatever zipper tricks you use on a hand-written tree you can also use on do notation. Just pass the do block itself as the tree. – Onlybegotten

I've read your blog on Free Monads a few more times and it's all coming together now. I have a couple more questions if you don't mind. I'm still a little fuzzy on how or where the "someUnion" function works. In "bool <- union" where is this union coming from? And where is someUnion used? Is it a part of my new syntax to be used in another do block to build a tree? And my last thought is, what do you think about using a GADT to combine the liftF into the constructors instead of having the separate smart constructor? Maybe that'll mess things up with the type. Thanks again for your time. – Skinhead

@Skinhead For the GADT part, what you want is the operational package which is equivalent to free monads and does exactly what you requested. If you expand the definition of liftF, then union becomes: union = Free (Union (Pure False) (Pure True)). In other words, it creates an "empty" Union with boolean values at the leaves. All the do notation is doing is binding the bools at those leaves. someUnion is a tree that you can pass directly to expressions that require trees. There is no difference between a tree built by hand and one built using do notation. – Onlybegotten

@Skinhead It's important to understand that do notation and the corresponding trees are interchangeable. For example, I can bind a hand-written tree in do notation using: bool <- Free (Union (Pure True) (Pure False). Dually, I can use do notation anywhere you would normally expect a tree, i.e.: Free (Union (do { translate' m1; sphere 4 }) (do { block 5 }). The do block is a tree itself. The do notation is simply syntactic sugar for an alternative way to build trees other than doing it by hand, but the block itself evaluates to a tree. – Onlybegotten