-
Notifications
You must be signed in to change notification settings - Fork 5
Notes for Week 19 Zippers
newmana edited this page Apr 17, 2012
·
35 revisions
- Online chapter
- http://www.haskell.org/haskellwiki/Zipper
- http://www.haskell.org/haskellwiki/Zipper_monad
- http://en.wikibooks.org/wiki/Haskell/Zippers
- Huet's Original Paper "The Zipper"
- http://scienceblogs.com/goodmath/2010/01/zippers_making_functional_upda.php
- Theseus and the Zipper
From the example in the book:
let newFocus = modify (\_ -> 'P') (goRight (goLeft (freeTree,[])))
What are the elements as in freeTree as it goes through the left and right branches and what element is replaced in the tree?
Implement a text editor that:
- Moves up a line,
- Moves down a line,
- Inserts a line,
- Deletes a line,
- Replaces a line,
- Moves to the start of the document,
- Moves to the end of the document.
Make sure we get can't go passed the top or bottom of the document.
Function signatures:
type HEdit = ([String], [String])
cursorUp :: HEdit -> HEdit
cursorDown :: HEdit -> HEdit
insertLine :: String -> HEdit -> HEdit
deleteLine :: HEdit -> HEdit
replaceLine :: String -> HEdit -> HEdit
startDocument :: HEdit -> HEdit
endDocument :: HEdit -> HEdit
Tests:
line1 = "first line"
line2 = "second line"
line3 = "third line"
emptyDocument = ([], [])
document = ([line1, line2, line3], [])
cursorUpOk1 = cursorUp(document) == document
cursorUpOk2 = cursorUp([line2, line3],[line1]) == document
cursorDownOk1 = cursorDown(document) == ([line2, line3], [line1])
cursorDownOk2 = cursorDown([], [line3, line2, line1]) == cursorDown([], [line3, line2, line1])
startDocumentOk = startDocument(cursorDown(cursorDown(document))) == document
endDocumentOk = endDocument(document) == ([], [line3, line2, line1])
insertLineOk = insertLine line1 (insertLine line2 (insertLine line3 emptyDocument)) == document
deleteLineOk1 = deleteLine document == ([line2, line3], [])
deleteLineOk2 = deleteLine emptyDocument == emptyDocument
deleteLineOk3 = deleteLine(endDocument(document)) == ([], [line2, line1])
replaceLineOk1 = replaceLine "skink" document == (["skink", line2, line3], [])
complicated = endDocument(replaceLine "george" (cursorUp(replaceLine "fred" (deleteLine(cursorDown(document)))))) == ([], ["fred", "george"])
allTests = [cursorUpOk1, cursorUpOk2, cursorDownOk1, cursorDownOk2, startDocumentOk, endDocumentOk, insertLineOk,
deleteLineOk1, deleteLineOk2, deleteLineOk3, replaceLineOk1, complicated]
A nexus is a tree that shares nodes (see page 3 of Functional Pearl Trouble Shared is Trouble Halved). It is used for memoisation - recording previously computed values. The example in the book is called "The Countdown Problem" which is like the numbers part of "Letters and Numbers". From the paper it gives a simple example, where it splits the value of the node into two parts using the following function:
isegs xs = [init xs, tail xs]
For example:
isegs [1,2,3,4] = [ [1,2,3],[2,3,4] ]
The inner nodes are shared, [2,3] is shared between tail [1,2,3] == init [2,3,4].
Write a program that simulates a nexus (I couldn't work out how to do a real one), using the following functions and data:
modify :: (a -> a) -> Zipper a -> Zipper a
modify f (Node x l r, bs) = (Node (f x) l r, bs)
modify f (Empty, bs) = (Empty, bs)
attach :: Tree a -> Zipper a -> Zipper a
attach t (_, bs) = (t, bs)
isegs xs = [init xs, tail xs]
okIsegs = isegs [1,2,3,4] == [ [1,2,3],[2,3,4] ]
nexus :: Tree [Int]
startNexus = Node ([1,2,3,4]) Empty Empty
endNexus =
Node [1,2,3,4]
(Node [1,2,3]
(Node [1,2]
(Node [1] Empty Empty)
(Node [2] Empty Empty)
)
(Node [2,3]
(Node [2] Empty Empty)
(Node [3] Empty Empty)
)
)
(Node [2,3,4]
(Node [2,3]
(Node [2] Empty Empty)
(Node [3] Empty Empty)
)
(Node [3,4]
(Node [3] Empty Empty)
(Node [4] Empty Empty)
)
)
Make this True:
okBeginNexus = fst (createNexus (startNexus,[])) == (endNexus)
Here are some functions that should help:
getISegs :: (t, [Crumb [a]]) -> [a]
getISegs (_, LeftCrumb x r:bs) = x -: isegs -: head
getISegs (_, RightCrumb x l:bs) = x -: isegs -: last
okGo :: (Tree [a], t) -> Bool
okGo (Node x l r, bs) = length x > 2
okGo (Empty, _) = False
attachLeftSeg :: (Tree [a], Breadcrumbs' [a]) -> Zipper [a]
attachLeftSeg nexus = nexus -: goLeft' -: attach (Node (goLeft' nexus -: getISegs) Empty Empty)
attachRightSeg :: (Tree [a], Breadcrumbs' [a]) -> Zipper [a]
attachRightSeg nexus = nexus -: goRight' -: attach (Node (goRight' nexus -: getISegs) Empty Empty)
The functions to implement (use okGo in an if-then-else in createNexus):
attachSegs :: (Tree [a], Breadcrumbs' [a]) -> (Tree [a], Breadcrumbs' [a])
createNexus :: (Tree [a], Breadcrumbs' [a]) -> (Tree [a], Breadcrumbs' [a])
//TODO
Starts at 'P', left to 'O', and right to 'Y' and replaces it with 'P'.
import qualified Data.Monoid as M
type HEdit = ([String], [String])
cursorDown :: HEdit -> HEdit
cursorDown (x:xs, bs) = (xs, x:bs)
cursorDown ([], bs) = ([], bs)
cursorUp :: HEdit -> HEdit
cursorUp (xs, b:bs) = (b:xs, bs)
cursorUp (xs, []) = (xs, [])
insertLine :: String -> HEdit -> HEdit
insertLine a (b, c) = (a:b, c)
deleteLine :: HEdit -> HEdit
deleteLine ([], []) = ([], [])
deleteLine ([], b:bs) = ([], bs)
deleteLine (x:xs, bs) = (xs, bs)
replaceLine :: String -> HEdit -> HEdit
replaceLine a (x:xs, b) = (a:xs, b)
startDocument :: HEdit -> HEdit
startDocument (xs, []) = (xs, [])
startDocument a = startDocument (cursorUp a)
endDocument :: HEdit -> HEdit
endDocument ([], bs) = ([], bs)
endDocument a = endDocument (cursorDown a)
line1 = "first line"
line2 = "second line"
line3 = "third line"
emptyDocument = ([], [])
document = ([line1, line2, line3], [])
cursorUpOk1 = cursorUp(document) == document
cursorUpOk2 = cursorUp([line2, line3],[line1]) == document
cursorDownOk1 = cursorDown(document) == ([line2, line3], [line1])
cursorDownOk2 = cursorDown([], [line3, line2, line1]) == cursorDown([], [line3, line2, line1])
startDocumentOk = startDocument(cursorDown(cursorDown(document))) == document
endDocumentOk = endDocument(document) == ([], [line3, line2, line1])
insertLineOk = insertLine line1 (insertLine line2 (insertLine line3 emptyDocument)) == document
deleteLineOk1 = deleteLine document == ([line2, line3], [])
deleteLineOk2 = deleteLine emptyDocument == emptyDocument
deleteLineOk3 = deleteLine(endDocument(document)) == ([], [line2, line1])
replaceLineOk1 = replaceLine "skink" document == (["skink", line2, line3], [])
complicated = endDocument(replaceLine "george" (cursorUp(replaceLine "fred" (deleteLine(cursorDown(document)))))) == ([], ["fred", "george"])
allTests = [cursorUpOk1, cursorUpOk2, cursorDownOk1, cursorDownOk2, startDocumentOk, endDocumentOk, insertLineOk,
deleteLineOk1, deleteLineOk2, deleteLineOk3, replaceLineOk1, complicated]
testAll = (M.getAll $ M.mconcat $ map M.All allTests) == True
data Tree a = Empty | Node a (Tree a) (Tree a) deriving (Show, Eq)
data Crumb a = LeftCrumb a (Tree a) | RightCrumb a (Tree a) deriving (Show)
type Breadcrumbs' a = [Crumb a]
type Zipper a = (Tree a, Breadcrumbs' a)
goLeft' :: (Tree a, Breadcrumbs' a) -> (Tree a, Breadcrumbs' a)
goLeft' (Node x l r, bs) = (l, LeftCrumb x r:bs)
goRight' :: (Tree a, Breadcrumbs' a) -> (Tree a, Breadcrumbs' a)
goRight' (Node x l r, bs) = (r, RightCrumb x l:bs)
goUp' :: (Tree a, Breadcrumbs' a) -> (Tree a, Breadcrumbs' a)
goUp' (t, LeftCrumb x r:bs) = (Node x t r, bs)
goUp' (t, RightCrumb x l:bs) = (Node x l t, bs)
attach :: Tree a -> Zipper a -> Zipper a
attach t (_, bs) = (t, bs)
x -: f = f x
isegs xs = [init xs, tail xs]
okIsegs = isegs [1,2,3,4] == [ [1,2,3],[2,3,4] ]
nexus :: Tree [Int]
nexus = Node ([1,2,3,4]) Empty Empty
endNexus =
Node [1,2,3,4]
(Node [1,2,3]
(Node [1,2]
(Node [1] Empty Empty)
(Node [2] Empty Empty)
)
(Node [2,3]
(Node [2] Empty Empty)
(Node [3] Empty Empty)
)
)
(Node [2,3,4]
(Node [2,3]
(Node [2] Empty Empty)
(Node [3] Empty Empty)
)
(Node [3,4]
(Node [3] Empty Empty)
(Node [4] Empty Empty)
)
)
getISegs :: (t, [Crumb [a]]) -> [a]
getISegs (_, LeftCrumb x r:bs) = x -: isegs -: head
-- Replace this function to use previously calculated result by going Up, Left and Right in the Zipper.
getISegs (_, RightCrumb x l:bs) = x -: isegs -: last
okGo :: (Tree [a], t) -> Bool
okGo (Node x l r, bs) = length x > 2
okGo (Empty, _) = False
attachLeftSeg :: (Tree [a], Breadcrumbs' [a]) -> Zipper [a]
attachLeftSeg nexus = nexus -: goLeft' -: attach (Node (goLeft' nexus -: getISegs) Empty Empty)
attachRightSeg :: (Tree [a], Breadcrumbs' [a]) -> Zipper [a]
attachRightSeg nexus = nexus -: goRight' -: attach (Node (goRight' nexus -: getISegs) Empty Empty)
attachSegs :: (Tree [a], Breadcrumbs' [a]) -> (Tree [a], Breadcrumbs' [a])
attachSegs nexus = nexus -: attachLeftSeg -: goUp' -: attachRightSeg -: goUp'
createNexus :: (Tree [a], Breadcrumbs' [a]) -> (Tree [a], Breadcrumbs' [a])
createNexus nexus = if (okGo nexus) then (attachSegs nexus -: goLeft' -: createNexus -: goUp' -: goRight' -: createNexus -: goUp') else (attachSegs nexus)
okBeginNexus = fst (createNexus (nexus,[])) == (endNexus)
10 Dimensions http://www.tenthdimension.com/medialinks.php