module Data.List.PointedList where
import Prelude hiding (foldl, foldr, elem)
import Control.Applicative
import Control.Monad
import Data.Accessor
import Data.Binary
import Data.Foldable hiding (find)
import Data.List hiding (length, foldl, foldr, find, elem)
import qualified Data.List as List
import Data.Maybe
import Data.Traversable
data PointedList a = PointedList [a] a [a]
deriving (Eq, Ord )
instance (Show a) => Show (PointedList a) where
show (PointedList ls x rs) = show (reverse ls) ++ " " ++ show x ++ " " ++ show rs
instance Functor PointedList where
fmap f (PointedList ls x rs) = PointedList (map f ls) (f x) (map f rs)
instance Foldable PointedList where
foldr f z (PointedList ls x rs) = foldl (flip f) (foldr f z (x:rs)) ls
instance Traversable PointedList where
traverse f (PointedList ls x rs) = PointedList <$> (reverse <$> traverse f (reverse ls)) <*> f x <*> traverse f rs
singleton :: a -> PointedList a
singleton x = PointedList [] x []
fromList :: [a] -> Maybe (PointedList a)
fromList [] = Nothing
fromList (x:xs) = Just $ PointedList [] x xs
fromListEnd :: [a] -> Maybe (PointedList a)
fromListEnd [] = Nothing
fromListEnd xs = Just $ PointedList xs' x []
where (x:xs') = reverse xs
focus :: PointedList a -> a
focus (PointedList _ x _) = x
focusA :: Accessor (PointedList a) a
focusA = accessor focus $ \b (PointedList a _ c) -> PointedList a b c
next :: PointedList a -> Maybe (PointedList a)
next (PointedList _ _ []) = Nothing
next p = (Just . tryNext) p
tryNext :: PointedList a -> PointedList a
tryNext p@(PointedList _ _ [] ) = error "cannot move to next element"
tryNext (PointedList ls x (r:rs)) = PointedList (x:ls) r rs
previous :: PointedList a -> Maybe (PointedList a)
previous (PointedList [] _ _ ) = Nothing
previous p = (Just . tryPrevious) p
tryPrevious :: PointedList a -> PointedList a
tryPrevious p@(PointedList [] _ _ ) =
error "cannot move to previous element"
tryPrevious (PointedList (l:ls) x rs) = PointedList ls l (x:rs)
insert :: a -> PointedList a -> PointedList a
insert = insertRight
insertLeft :: a -> PointedList a -> PointedList a
insertLeft y (PointedList ls x rs) = PointedList ls y (x:rs)
insertRight :: a -> PointedList a -> PointedList a
insertRight y (PointedList ls x rs) = PointedList (x:ls) y rs
delete :: PointedList a -> Maybe (PointedList a)
delete = deleteRight
deleteLeft :: PointedList a -> Maybe (PointedList a)
deleteLeft (PointedList [] _ [] ) = Nothing
deleteLeft (PointedList (l:ls) _ rs) = Just $ PointedList ls l rs
deleteLeft (PointedList [] _ (r:rs)) = Just $ PointedList [] r rs
deleteRight :: PointedList a -> Maybe (PointedList a)
deleteRight (PointedList [] _ [] ) = Nothing
deleteRight (PointedList ls _ (r:rs)) = Just $ PointedList ls r rs
deleteRight (PointedList (l:ls) _ []) = Just $ PointedList ls l []
deleteOthers :: PointedList a -> PointedList a
deleteOthers (PointedList _ b _) = PointedList [] b []
length :: PointedList a -> Int
length = foldr (const (+1)) 0
atStart :: PointedList a -> Bool
atStart (PointedList [] _ _) = True
atStart _ = False
atEnd :: PointedList a -> Bool
atEnd (PointedList _ _ []) = True
atEnd _ = False
positions :: PointedList a -> PointedList (PointedList a)
positions p@(PointedList ls x rs) = PointedList left p right
where left = unfoldr (\p -> fmap (join (,)) $ previous p) p
right = unfoldr (\p -> fmap (join (,)) $ next p) p
contextMap :: (PointedList a -> b) -> PointedList a -> PointedList b
contextMap f z = fmap f $ positions z
withFocus :: PointedList a -> PointedList (a, Bool)
withFocus (PointedList a b c) = PointedList (zip a (repeat False)) (b, True) (zip c (repeat False))
move :: Int -> PointedList a -> Maybe (PointedList a)
move n pl@(PointedList a _ _) | n < 0 || n >= Data.List.PointedList.length pl
= Nothing
| Prelude.length a == n = Just pl
| Prelude.length a >= n = move n (tryPrevious pl)
| otherwise = move n (tryNext pl)
find :: Eq a => a -> PointedList a -> Maybe (PointedList a)
find x pl = find' ((x ==) . focus) $ positions pl
where find' pred (PointedList a b c) =
if pred b then Just b
else List.find pred (a ++ c)
merge [] ys = ys
merge (x:xs) ys = x : merge ys xs
index :: PointedList a -> Int
index (PointedList a _ _) = Prelude.length a
instance Binary t1 => Binary (PointedList t1)
where put (PointedList x1
x2
x3) = return () >> (put x1 >> (put x2 >> put x3))
get = case 0 of
0 -> ap (ap (ap (return PointedList) get) get) get