Purely Functional Deque

Deque.hs

{-# LANGUAGE ViewPatterns, PatternSynonyms #-}

module Deque where 

import Text.Read
import Data.Bifunctor
import Prelude hiding (length, init, tail, last, head) 
import qualified Prelude as P
                  
data Deque a =
  Deque { lenL  :: !Int, lenR   :: !Int
        , left  :: ![a], right  :: ![a]
        , left' :: ![a], right' :: ![a] }

pattern Empty :: Deque a 
pattern Empty <- (isEmpty -> True) 
  where Empty = empty 

pattern (:<) :: a -> Deque a -> Deque a 
pattern x :< dq <- (viewL -> (x, dq)) 
  where x :< dq = insertL x dq 

pattern (:>) :: Deque a -> a -> Deque a 
pattern dq :> x <- (viewR -> (x, dq)) 
  where dq :> x = insertR x dq 

infixr 6 :< 
infixl 6 :> 

instance Show a => Show (Deque a) where 
  show = showString "fromList " . show . toList

instance Read a => Read (Deque a) where
  readPrec = fmap fromList readPrec

instance Eq a => Eq (Deque a) where
  xs == ys = length xs == length ys && toList xs == toList ys

instance Ord a => Ord (Deque a) where
  xs `compare` ys = toList xs `compare` toList ys 


toList :: Deque a -> [a]
toList dq = apprev (left dq) (right dq) []

fromList :: [a] -> Deque a
fromList xs = let (ys, zs) = splitAt (P.length xs `div` 2) xs in go (reverse ys) zs empty
  where
    go (y:ys) (z:zs) dq = go ys zs ((y :< dq) :> z)
    go []     (z:zs) dq = go [] zs (dq :> z)
    go (y:ys) []     dq = go ys [] (y :< dq) 
    go []     []     dq = dq 

empty :: Deque a 
empty = Deque 0 0 [] [] [] []

isEmpty :: Deque a -> Bool
isEmpty dq = length dq == 0

length :: Deque a -> Int
length dq = lenL dq + lenR dq 

tail :: Deque a -> Deque a
tail (_ :< dq) = dq

init :: Deque a -> Deque a
init (dq :> _) = dq

head :: Deque a -> a
head (x :< _) = x

last :: Deque a -> a
last (_ :> x) = x

insertL :: a -> Deque a -> Deque a 
insertL x (Deque n m xs ys xs' ys') = makedq (n+1) m (x:xs) ys (tl xs') (tl ys')

insertR :: a -> Deque a -> Deque a
insertR x (Deque n m xs ys xs' ys') = makedq n (m+1) xs (x:ys) (tl xs') (tl ys')

viewL :: Deque a -> (a, Deque a)
viewL (Deque _ _ []     ys _   _  ) = (P.head ys, empty)
viewL (Deque n m (x:xs) ys xs' ys') = (x, makedq (n-1) m xs ys (tl $ tl xs') (tl $ tl ys'))

viewR :: Deque a -> (a, Deque a)
viewR (Deque _ _ xs []     _   _  ) = (P.head xs, empty)
viewR (Deque n m xs (y:ys) xs' ys') = (y, makedq n (m-1) xs ys (tl $ tl xs') (tl $ tl ys'))

{-# INLINE ratio #-}
ratio :: Int 
ratio = 2 

makedq :: Int -> Int -> [a] -> [a] -> [a] -> [a] -> Deque a 
makedq n m xs ys xs' ys'
  | n > ratio * m + 1 = 
    let mid = (n + m) `div` 2
        xs0 = take mid xs
        ys0 = rot1 mid m n ys xs
    in Deque mid (n+m-mid) xs0 ys0 xs0 ys0 
  | m > ratio * n + 1 = 
    let mid = (n+m) `div` 2
        xs0 = rot1 mid n m xs ys
        ys0 = take mid ys 
    in Deque (n+m-mid) mid xs0 ys0 xs0 ys0
  | otherwise = Deque n m xs ys xs' ys' 

rot1 :: Int -> Int -> Int -> [a] -> [a] -> [a]
rot1 mid n m xs ys 
  | mid >= ratio  = P.head xs:rot1 (mid-ratio) (n-1) (m-ratio) (tl xs) (drop ratio ys) 
  | otherwise = rot2 n m xs (drop mid ys) []

rot2 :: Int -> Int -> [a] -> [a] -> [a] -> [a] 
rot2 n m xs ys zs 
  | n > 0 && m >= ratio = 
    P.head xs:rot2 (n-1) (m-ratio) (tl xs) (drop ratio ys) (reverse (take ratio ys) ++ zs)
  | otherwise = apprev xs ys zs 

apprev :: [a] -> [a] -> [a] -> [a] 
apprev xs     []     zs = xs ++ zs 
apprev []     (y:ys) zs = apprev [] ys (y:zs) 
apprev (x:xs) (y:ys) zs = x:apprev xs ys (y:zs) 

tl :: [a] -> [a]
tl []  = []
tl xs = P.tail xs