ðŸŽ‰ Exercism Research is now launched. Help Exercism, help science and have some fun at research.exercism.io ðŸŽ‰

# MarkH's solution

## to Zipper in the Haskell Track

Published at Sep 17 2020 · 0 comments
Instructions
Test suite
Solution

#### Note:

This exercise has changed since this solution was written.

Creating a zipper for a binary tree.

Zippers are a purely functional way of navigating within a data structure and manipulating it. They essentially contain a data structure and a pointer into that data structure (called the focus).

For example given a rose tree (where each node contains a value and a list of child nodes) a zipper might support these operations:

• `from_tree` (get a zipper out of a rose tree, the focus is on the root node)
• `to_tree` (get the rose tree out of the zipper)
• `value` (get the value of the focus node)
• `prev` (move the focus to the previous child of the same parent, returns a new zipper)
• `next` (move the focus to the next child of the same parent, returns a new zipper)
• `up` (move the focus to the parent, returns a new zipper)
• `set_value` (set the value of the focus node, returns a new zipper)
• `insert_before` (insert a new subtree before the focus node, it becomes the `prev` of the focus node, returns a new zipper)
• `insert_after` (insert a new subtree after the focus node, it becomes the `next` of the focus node, returns a new zipper)
• `delete` (removes the focus node and all subtrees, focus moves to the `next` node if possible otherwise to the `prev` node if possible, otherwise to the parent node, returns a new zipper)

## Getting Started

Please refer to the installation and learning help pages.

## Running the tests

To run the test suite, execute the following command:

``````stack test
``````

#### If you get an error message like this...

``````No .cabal file found in directory
``````

You are probably running an old stack version and need to upgrade it.

#### Otherwise, if you get an error message like this...

``````No compiler found, expected minor version match with...
Try running "stack setup" to install the correct GHC...
``````

Just do as it says and it will download and install the correct compiler version:

``````stack setup
``````

## Running GHCi

If you want to play with your solution in GHCi, just run the command:

``````stack ghci
``````

## Feedback, Issues, Pull Requests

The exercism/haskell repository on GitHub is the home for all of the Haskell exercises.

If you have feedback about an exercise, or want to help implementing a new one, head over there and create an issue. We'll do our best to help you!

## Submitting Incomplete Solutions

It's possible to submit an incomplete solution so you can see how others have completed the exercise.

### Tests.hs

``````import Data.Maybe        (fromJust)
import Test.Hspec        (Spec, it, shouldBe)
import Test.Hspec.Runner (configFastFail, defaultConfig, hspecWith)

import Zipper
( BinTree(BT)
, fromTree
, left
, right
, setLeft
, setRight
, setValue
, toTree
, up
, value
)

main :: IO ()
main = hspecWith defaultConfig {configFastFail = True} specs

specs :: Spec
specs = do

let leaf v     = node v Nothing Nothing
node v l r = Just (BT v l r :: BinTree Int)
t1         = BT 1 (node 2 Nothing  \$ leaf 3) \$ leaf 4
t2         = BT 1 (node 5 Nothing  \$ leaf 3) \$ leaf 4
t3         = BT 1 (node 2 (leaf 5) \$ leaf 3) \$ leaf 4
t4         = BT 1 (leaf 2                  ) \$ leaf 4
t5         = BT 6 (leaf 7                  ) \$ leaf 8
t6         = BT 1 (node 2 Nothing  \$ leaf 3) \$ node 6 (leaf 7) (leaf 8)
t7         = BT 1 (node 2 Nothing  \$ leaf 5) \$ leaf 4

it "data is retained" \$
toTree (fromTree t1)
`shouldBe` t1

it "left, right and value" \$
(value . fromJust . right . fromJust . left . fromTree) t1
`shouldBe` 3

(left . fromJust . left . fromTree) t1
`shouldBe` Nothing

it "traversing up from top" \$
(up . fromTree) t1
`shouldBe` Nothing

it "left, right, and up" \$
(value . fromJust . right . fromJust . left . fromJust . up . fromJust . right . fromJust . up . fromJust . left . fromTree) t1
`shouldBe` 3

it "tree from deep focus" \$
(toTree . fromJust . right . fromJust . left . fromTree) t1
`shouldBe` t1

it "setValue" \$
(toTree . setValue 5 . fromJust . left . fromTree) t1
`shouldBe` t2

it "setValue after traversing up" \$
(toTree . setValue 5 . fromJust . up . fromJust . right . fromJust . left . fromTree) t1
`shouldBe` t2

it "setLeft with Just" \$
(toTree . setLeft (leaf 5) . fromJust . left . fromTree) t1
`shouldBe` t3

it "setRight with Nothing" \$
(toTree . setRight Nothing . fromJust . left . fromTree) t1
`shouldBe` t4

it "setRight with subtree" \$
(toTree . setRight (Just t5) . fromTree) t1
`shouldBe` t6

it "setValue on deep focus" \$
(toTree . setValue 5 . fromJust . right . fromJust . left . fromTree) t1
`shouldBe` t7

it "different paths to same zipper" \$
(right . fromJust . up . fromJust . left . fromTree) t1
`shouldBe` (right . fromTree) t1``````
``````module Zipper
( BinTree(BT)
, fromTree
, left
, right
, setLeft
, setRight
, setValue
, toTree
, up
, value
) where

import Data.BinaryTree  ( BinaryTree(..))
import qualified Data.BinaryTree.Zipper as Z
import Data.BinaryTree.Zipper   ( BinaryTreeZipper(..)
, Ctx(..)
, toRoot
)

data BinTree a = BT { btValue :: a
, btLeft  :: Maybe (BinTree a)
, btRight :: Maybe (BinTree a)
} deriving (Eq, Show)

type Zipper a = BinaryTreeZipper a

binTreeToBinaryTree     -- Convert a BinTree to a BinaryTree
:: BinTree a        -- tree to convert
-> BinaryTree a     -- converted tree
binTreeToBinaryTree (BT x Nothing Nothing) =
Internal Nil x Nil
binTreeToBinaryTree (BT x (Just l) Nothing) =
Internal (binTreeToBinaryTree l) x Nil
binTreeToBinaryTree (BT x Nothing (Just r)) =
Internal Nil x (binTreeToBinaryTree r)
binTreeToBinaryTree (BT x (Just l) (Just r)) =
Internal (binTreeToBinaryTree l) x (binTreeToBinaryTree r)

binaryTreeToBinTree -- convert BinaryTree to BinTree
:: BinaryTree a -- tree to convert
-> BinTree a    -- converted tree
binaryTreeToBinTree Nil = error "BinTree can't be empty"
binaryTreeToBinTree (Internal Nil x Nil) =
BT x Nothing Nothing
binaryTreeToBinTree (Internal l x Nil) =
BT x (Just \$ binaryTreeToBinTree l) Nothing
binaryTreeToBinTree (Internal Nil x r) =
BT x Nothing (Just \$ binaryTreeToBinTree r)
binaryTreeToBinTree (Internal l x r) =
BT  x
(Just \$ binaryTreeToBinTree l)
(Just \$ binaryTreeToBinTree r)

fromTree            -- Make a zipper with hole at top
:: BinTree a    -- tree to zipper
-> Zipper a     -- resulting zipper
fromTree = (`Loc` Top) . binTreeToBinaryTree

toTree              -- Given a zipper, return tree at top
:: Zipper a     -- zipper
-> BinTree a    -- tree at hole
toTree = hole . toRoot

hole
:: Zipper a
-> BinTree a
hole (Loc tree _) = binaryTreeToBinTree tree

value               -- return the node value at the hole
:: Zipper a     -- zipper
-> a            -- hole node value
value (Loc Nil _) = error "No value for empty tree"
value (Loc (Internal _ x _) _) = x

nilToNothing
:: Maybe (Zipper a)
-> Maybe (Zipper a)
nilToNothing (Just (Loc Nil _)) = Nothing
nilToNothing zpr = zpr

left                -- go down to the left child in zipper
:: Zipper a     -- zipper
-> Maybe (Zipper a) -- updated zipper
left = nilToNothing . Z.left

right                   -- go down to right child in zipper
:: Zipper a         -- zipper
-> Maybe (Zipper a) -- updated
right = nilToNothing . Z.right

up                      -- go up to parent in zipper
:: Zipper a         -- zipper
-> Maybe (Zipper a) -- updated zipper
up = nilToNothing . Z.up

setValue            -- Set the node value at the hole to value
:: a            -- value
-> Zipper a     -- zipper
-> Zipper a     -- modified zipper
setValue _ (Loc Nil ctx) = Loc Nil ctx
setValue x (Loc (Internal l _ r) ctx) = Loc (Internal l x r) ctx

setLeft             -- Set the left subtree at the hole
:: Maybe (BinTree a)    -- new left subtree
-> Zipper a             -- zipper
-> Zipper a             -- modified zipper
setLeft _ (Loc Nil ctx) = Loc Nil ctx
setLeft Nothing (Loc (Internal _ x r) ctx) =
Loc (Internal Nil x r) ctx
setLeft (Just l) (Loc (Internal _ x r) ctx) =
Loc (Internal (binTreeToBinaryTree l) x r) ctx

setRight            -- Set the right subtree at the hole
:: Maybe (BinTree a)    -- new right subtree
-> Zipper a             -- zipper
-> Zipper a             -- updated zipper
setRight _ (Loc Nil ctx) = Loc Nil ctx
setRight Nothing (Loc (Internal l x _) ctx) =
Loc (Internal l x Nil) ctx
setRight (Just r) (Loc (Internal l x _) ctx) =
Loc (Internal l x (binTreeToBinaryTree r)) ctx``````