[Haskell-cafe] Doubly-linked zipper list w/ insert implementation

[Justin Bailey]

The other day I decided to implement a ring buffer with a current
element (i.e. a doubly-linked zipper list). In order to allow inserts
(and, in the future, deletes and updates), I have a special sentinel
element called "Join" in the structure. When inserting, I find the
join first, insert and then rebuild the buffer using circular
programming techniques. This also allows the buffer to be converted
back to a list. The current element can be changed by rotating right
or left, which never fails. Rotating n positions takes n steps.

I'm posting it here for comments and feedback. How could the structure
be smarter? Would storing a unique ID with each element make more
sense? Any comments on the space behavior under insert and rotates? I
wanted to "maximize" sharing. Thanks in advance.

Justin

p.s. The original motivation for writing this was to model cellular
automata. The CA world is "circular", so that got me thinking about a
structure that made connecting the ends easy to do.

-- cut here ---

module Ring (Ring, create, insert, current, rotR, rotL, toListL, toListR)
-- Thanks to Keith Wansbrough  for his posting describing a doubly-linked list
-- in Haskell for inspiration here.
-- 
-- http://groups.google.com/group/comp.lang.functional/msg/8c65fdd16f7e91e1
where

import Data.List (foldl')
-- For testing
import Test.QuickCheck
import Control.Monad (replicateM_)
import System.Random (randomRIO)
import System.Environment (getArgs)

data Ring a = Ring (Ring a) a (Ring a) | Join (Ring a) (Ring a)

instance (Show a) => Show (Ring a) where
  show r = "{" ++ show' (findLeftOfJoin r)
    where
      show' (Join _ _) = "}"
      show' (Ring l v _)
        | isJoin l = show v ++ show' l
        | otherwise = show v ++ "," ++ show' l

create v =
  let me = Ring join v join
      join = Join me me
  in me

insert r a =
    let (left, right) = insert' left right start a
        start = findLeftOfJoin r
    in left
  where
    insert' left right (Join _ _) val =
      let last = Ring join val right
          join = Join left last
      in (last, join)
    insert' left right (Ring l v _) val =
      let this = Ring newL val right
          (newL, newR) = insert' left this l v
      in (this, newR)

fromList [] = error "Can't create empty ring"
fromList ls =
    let (left, right) = fromList' left right ls
    in left
  where
    -- compute this ring, given left and right pointers. Return
    -- left and right pointers for this segment
    fromList' left right [] =
      let join = Join left right
      in (join, right)
    fromList' left right (x:xs) =
      let this = Ring l x right
          (l, r) = fromList' left this xs
      in (this, r)

toList = toListL

-- View of list from left hand side
toListL = toList' . findLeftOfJoin
  where
    toList' (Join _ _) = []
    toList' (Ring l v _) = v : toList' l

toListR = toList' . findRightOfJoin
  where
    toList' (Join _ _) = []
    toList' (Ring _ v r) = v : toList' r

current (Ring r v l) = v
current _ = error "Join is never current (curr)"

rotR r amt
  | amt > 0 = goRight r amt
  | amt < 0 = goLeft r (negate amt)
  | otherwise = r

rotL r amt
  | amt > 0 = goLeft r amt
  | amt < 0 = goRight r (negate amt)
  | otherwise = r

goRight r 0 = r
goRight (Ring _ _ r@(Ring _ _ _)) amt = goRight r (amt - 1)
goRight (Ring _ _ (Join _ r)) amt = goRight r (amt - 1)
goRight (Join _ _) _ = error "Join is never current (goRight)"

goLeft r 0 = r
goLeft (Ring l@(Ring _ _ _) _ _) amt = goLeft l (amt - 1)
goLeft (Ring (Join l _) _ _) amt = goLeft l (amt - 1)
goLeft (Join _ _) _ = error "Join is never current (goLeft)"

isRing (Ring _ _ _) = True
isRing _ = False

isJoin (Join _ _) = True
isJoin _ = False

findLeftOfJoin (Join l _) = l
findLeftOfJoin (Ring l _ _) = findLeftOfJoin l

findRightOfJoin (Join _ r) = r
findRightOfJoin (Ring _ _ r) = findRightOfJoin r