I think I found a solution to this, if you're still looking for one. See
attached code. It uses a rose tree zipper where tree depth is manhattan
distance from origin and forest width is nodes around concentric
diamonds. The code is straightforward. Polar coords (RK) are stored in
node label, with conversion to/from cartesian calculated on the fly (but
may also be stored in label if speed is more important than time).
Cyclic closed loop tests like your f below run in constant space for me.
Dan Weston
Martijn van Steenbergen wrote:
Hello,
I would like to construct an infinite two-dimensional grid of nodes,
where a node looks like this:
data Node = Node
{ north :: Node
, east :: Node
, south :: Node
, west :: Node
}
in such a way that for every node n in the grid it doesn't matter how I
travel to n, I always end up in the same memory location for that node.
I suspect another way of saying that is that
let f = f . north . east . south . west in f origin
should run in constant space. I hope this makes the problem clear. :-)
How do I do this?
Thanks in advance,
Martijn.
-- |2-D infinite grid with O(1) lookup, modification, and incremental move
--
-- Data is saved sparsely (wrapped in Maybe) with a rose tree zipper
-- where depth is manhattan distance from origin, and sibling index is order
-- CCW around a diamond centered at origin. Sparsity maximized by storing
-- only nonempty nodes (save that every radius below max has at least one node).
--
-- Uses "Data.Tree.Zipper" which can be found on hackage at
-- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/rosezipper>
--
-- Data.Tree is indexed by Int. For unbounded grid, rewrite this code,
-- Data.Tree, and Data.Tree.Zipper to use Integer (should be straightforward).
--
-- Copyright (c) Dan Weston, 2008. All rights reserved.
--
-- License: Simplified BSD. See bottom of source file for details.
module GridZipper (
-- * Grid representation
module Data.Tree,
module Data.Tree.Zipper,
GridLabel(..),
Grid,
GridZipper,
newGrid,
-- * Grid coordinates
XY(..),
RK(..),
getRK,getXY,
cartesianFromPolar,polarFromCartesian,
-- * Grid values
getValue,newValue,setValue,
-- * Moving around the grid
goToRK,goToXY,moveInXY,north,south,east,west,
-- * Example usage
assocList,sampleUsage
) where
import Data.Tree.Zipper(TreeLoc,getLabel,setLabel,modifyLabel,
root,parent,left,right,firstChild,toTree,fromTree,
insertRight,insertDownFirst)
import Data.Tree (Tree,flatten)
import Data.Maybe (maybe,isJust,fromJust)
------------------------------------------------------------------------------
-- DATA TYPES
------------------------------------------------------------------------------
-- |Cartesian grid coordinates
data XY = XY Int Int deriving (Eq,Show)
-- |Polar grid coordinates
-- r = |x| + |y| (manhattan distance form origin)
-- k = index around diamond, starting at (+r,0)
data RK = RK Int Int deriving (Eq,Show)
-- |Grid label
data GridLabel a = GridLabel RK (Maybe a) deriving (Eq,Show)
-- |Grid represented as rose tree (radius = depth, angle = width)
type Grid a = Tree (GridLabel a)
-- |Cursor is rose tree zipper (polar coords stored in label alongside value)
type GridZipper a = TreeLoc (GridLabel a)
------------------------------------------------------------------------------
-- COORDINATE CONVERSION
------------------------------------------------------------------------------
-- |Gets cartesian coordinates from polar ones
cartesianFromPolar :: RK -> XY
cartesianFromPolar (RK 0 0) = XY 0 0
cartesianFromPolar (RK r k) = case q of
0 -> XY (r - s ) (s )
1 -> XY (negate s) (r - s )
2 -> XY (s - r ) (negate s)
3 -> XY (s ) (s - r )
where (q,s) = k `divMod` r
-- |Gets polar coordinates from cartesian ones
polarFromCartesian :: XY -> RK
polarFromCartesian (XY 0 0) = RK 0 0
polarFromCartesian (XY x y)
| x > 0 && y >= 0 = RK r y
| y > 0 && x <= 0 = RK r (r - x)
| x < 0 && y <= 0 = RK r (2*r - y)
| y < 0 && x >= 0 = RK r (3*r + x)
where r = abs x + abs y
------------------------------------------------------------------------------
-- COORDINATE ACCESS
------------------------------------------------------------------------------
-- |Extracts polar coordinates from label
getRK :: GridLabel a -> RK
getRK (GridLabel rk _) = rk
-- |Extracts cartesian coordinates from label
getXY :: GridLabel a -> XY
getXY = cartesianFromPolar . getRK
------------------------------------------------------------------------------
-- VALUE ACCESS AND MODIFY
------------------------------------------------------------------------------
-- |Extracts grid value, if any, from label
getValue :: GridLabel a -> Maybe a
getValue (GridLabel _ value) = value
-- |Returns copy, replacing grid value
newValue :: Maybe a -> GridLabel a -> GridLabel a
newValue v (GridLabel rk _) = GridLabel rk v
-- |Returns copy, replacing grid value
setValue :: Maybe a -> GridZipper a -> GridZipper a
setValue v = modifyLabel (newValue v)
------------------------------------------------------------------------------
-- NODE CREATION
------------------------------------------------------------------------------
-- |New empty grid
newGrid :: Grid a
newGrid = newNode (RK 0 0)
------------------------------------------------------------------------------
-- MOVING THROUGH GRID
------------------------------------------------------------------------------
-- |Move to new polar coords
goToRK :: RK -> GridZipper a -> GridZipper a
goToRK rk@(RK r k) z
| r < 0 = error "goToRK called with r < 0"
| r == 0 = root z
| r == rCurr = moveAround rk . leftmostSibling $ z
| r > rCurr = moveOut rCurr rk z
| otherwise = moveIn rCurr rk z
where RK rCurr _ = getRK . getLabel $ z
-- Move to new cartesian coordinate
goToXY :: XY -> GridZipper a -> GridZipper a
goToXY = goToRK . polarFromCartesian
-- |Move relatively in delta cartesian coordinates
moveInXY :: Int -> Int -> GridZipper a -> GridZipper a
moveInXY dx dy z = goToXY (XY (xOld + dx) (yOld + dy)) $ z
where XY xOld yOld = getXY . getLabel $ z
-- |Move up one step
north :: GridZipper a -> GridZipper a
north = moveInXY 0 1
-- |Move down one step
south :: GridZipper a -> GridZipper a
south = moveInXY 0 (-1)
-- |Move right one step
east :: GridZipper a -> GridZipper a
east = moveInXY 1 0
-- |Move left one step
west :: GridZipper a -> GridZipper a
west = moveInXY (-1) 0
-- |Display grid as association list: (xy,getValue)
assocList :: GridZipper a -> [(XY,a)]
assocList = map (\l -> (getXY $ l,
fromJust . getValue $ l))
. filter (isJust . getValue)
. flatten
. toTree
. root
-- |Example of walking grid from origin, setting values
--
-- > sampleUsage = putStrLn . show . (assocList &&& id) . walkGrid . fromTree
-- > $ (newGrid :: Grid String)
-- > where f &&& g = \x -> (f x, g x)
-- > f >>> g = g . f
-- > walkGrid = east >>> setValue (Just "XY 1 0")
-- > >>> north >>> west >>> setValue (Just "XY 0 1")
-- > >>> south >>> setValue (Just "XY 0 0")
-- > >>> south >>> setValue (Just "XY 0 (-1)")
--
sampleUsage :: IO ()
sampleUsage = putStrLn . show . (assocList &&& id) . walkGrid . fromTree
$ (newGrid :: Grid String)
where f &&& g = \x -> (f x, g x)
f >>> g = g . f
walkGrid = east >>> setValue (Just "XY 1 0")
>>> north >>> west >>> setValue (Just "XY 0 1")
>>> south >>> setValue (Just "XY 0 0")
>>> south >>> setValue (Just "d(XY 0 (-1)")
------------------------------------------------------------------------------
-- HELPER FUNCTIONS NOT EXPORTED
------------------------------------------------------------------------------
-- |Returns a new node, intended for a given polar coordinate
-- Note that all grids are anchored at the origin. Only the origin node
-- functions as a valid standalone grid.
newNode :: RK -> Grid a
newNode rk = return (GridLabel rk Nothing)
-- |Gets leftmost sibling of current node (which may be current one)
leftmostSibling :: GridZipper a -> GridZipper a
leftmostSibling z = maybe z leftmostSibling . left $ z
-- |Gets rightmost sibling of current node (which may be current one)
rightmostSibling :: GridZipper a -> GridZipper a
rightmostSibling z = maybe z rightmostSibling . right $ z
-- |Move inward to new polar coordinate
moveIn :: Int -> RK -> GridZipper a -> GridZipper a
moveIn rCurr rk@(RK r k) z
| rCurr == r = moveAround rk . leftmostSibling $ z
| otherwise = moveIn (rCurr - 1) rk . fromJust . parent $ z
-- |Move outward to new polar coordinate
moveOut :: Int -> RK -> GridZipper a -> GridZipper a
moveOut rCurr rk@(RK r k) z
| r == rCurr+1 = zChild
| otherwise = moveOut (rCurr + 1) rk zChild
where zChild = moveOutOne rk z
-- |Move outward exactly one unit of radius to new polar coordinate
-- This special case allows us to check if there is no child there and,
-- if so, to pick the angular anchor
-- Note that r passed in must be exactly one more than that of current node
moveOutOne :: RK -> GridZipper a -> GridZipper a
moveOutOne rk@(RK r k) z
= maybe (insertDownFirst (newNode rk) z) (moveAround rk) $ firstChild z
-- |Move relatively in angle around origin (along diamond perimeter)
-- Note that r passed in must match that of current node
moveAround :: RK -> GridZipper a -> GridZipper a
moveAround rk@(RK r k) z
| k == kCurr = z
| otherwise = maybe (insertRight (newNode rk) z) (moveAround rk) $ right z
where RK _ kCurr = getRK . getLabel $ z
------------------------------------------------------------------------------
-- LICENSE
------------------------------------------------------------------------------
{-
Copyright (c) Dan Weston, 2008. All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
-}
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
