Skip to content

Instantly share code, notes, and snippets.

@L-TChen
Last active January 18, 2019 19:14
Show Gist options
  • Save L-TChen/d99d859ce4aee8043a0eae7b747edc56 to your computer and use it in GitHub Desktop.
Save L-TChen/d99d859ce4aee8043a0eae7b747edc56 to your computer and use it in GitHub Desktop.
Purely Functional Deque
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment