GridZipper

Grid.hs

{-# LANGUAGE RecordWildCards #-}

module Grid where

import Data.Maybe

newtype Grid a = Grid { unGrid :: [[a]] }

type ListZipper a = ([a], a, [a])

focusListAt :: Int -> [a] -> Maybe (ListZipper a)
focusListAt = go []
  where
    go _   _ []        = Nothing
    go acc 0 (hd : tl) = Just (acc, hd, tl)
    go acc n (hd : tl) = go (hd : acc) (n - 1) tl

data GridZipper a =
  GridZipper { above :: Grid a
             , below :: Grid a
             , left  :: [a]
             , right :: [a]
             , focus :: a }

focusGridAt :: Int -> Int -> Grid a -> Maybe (GridZipper a)
focusGridAt x y g = do
  (before, line , after) <- focusListAt x $ unGrid g
  (left  , focus, right) <- focusListAt y line
  let above = Grid before
  let below = Grid after
  return GridZipper{..}

goLeft :: GridZipper a -> Maybe (GridZipper a)
goLeft g@GridZipper{..} =
  case left of
    []      -> Nothing
    (hd:tl) -> Just $ g { focus = hd, left = tl, right = focus : right }

goRight :: GridZipper a -> Maybe (GridZipper a)
goRight g@GridZipper{..} =
  case right of
    []      -> Nothing
    (hd:tl) -> Just $ g { focus = hd, left = focus : left, right = tl }

goUp :: GridZipper a -> Maybe (GridZipper a)
goUp GridZipper{..} = do
  let (line : above')     = unGrid above
  let below'              = (reverse left ++ focus : right) : unGrid below
  (left', focus', right') <- focusListAt (length left) line
  return $ GridZipper { above = Grid above'
                      , below = Grid below'
                      , left  = left'
                      , right = right'
                      , focus = focus' }

goDown :: GridZipper a -> Maybe (GridZipper a)
goDown GridZipper{..} = do
  let (line : below')     = unGrid below
  let above'              = (reverse left ++ focus : right) : unGrid above
  (left', focus', right') <- focusListAt (length left) line
  return $ GridZipper { above = Grid above'
                      , below = Grid below'
                      , left  = left'
                      , right = right'
                      , focus = focus' }

mkGrid :: Int -> Int -> Grid (Int, Int)
mkGrid m n = Grid $ [ zip (repeat i) [0..n-1] | i <- [0..m-1] ]

instance Show a => Show (Grid a) where
  show = concatMap (('\n' :) . concatMap show) . unGrid

instance Show a => Show (GridZipper a) where
  show GridZipper{..} =
    concat [ show above, "\n"
           , concatMap show (reverse left)
           , "\x1B[33m[\x1B[0m",  show focus, "\x1B[33m]\x1B[0m"
           , concatMap show right
           , show below ]

main :: IO ()
main = do
  let grid1 = mkGrid 5 10
  print grid1
  let grid2 = fromJust $ focusGridAt 2 3 grid1
  print grid2
  print $ goLeft =<< goLeft =<< goDown =<< goDown grid2