{-|
Module      : Advent.Queue
Description : FIFO queue implementation
Copyright   : (c) Eric Mertens, 2021
License     : ISC
Maintainer  : emertens@gmail.com

-}
{-# Language PatternSynonyms, ViewPatterns #-}
{-# Options_GHC -Wno-name-shadowing #-}
module Advent.Queue (Queue(Empty, (:<|)), (|>), singleton, fromList, snoc, pop, appendList) where

import Data.Foldable (Foldable(..))

-- | FIFO Queue implementation
data Queue a = Queue [a] [a] !Int

{-# COMPLETE (:<|), Empty #-}

-- | Empty queue
--
-- >>> Empty :: Queue Char
-- fromList ""
pattern Empty :: Queue a
pattern $mEmpty :: forall {r} {a}. Queue a -> ((# #) -> r) -> ((# #) -> r) -> r
$bEmpty :: forall a. Queue a
Empty <- Queue [] _ _
  where
    Empty = [a] -> [a] -> Int -> Queue a
forall a. [a] -> [a] -> Int -> Queue a
Queue [] [] Int
0

-- | Pattern for 'pop'
--
-- >>> let x :<| xs = fromList "abc" in (x, xs)
-- ('a',fromList "bc")
pattern (:<|) :: a -> Queue a -> Queue a
pattern x $m:<| :: forall {r} {a}. Queue a -> (a -> Queue a -> r) -> ((# #) -> r) -> r
:<| xs <- (pop -> Just (x, xs))

-- | Add an element to the end of a queue. See: 'snoc'
--
-- >>> fromList "abc" |> 'z'
-- fromList "abcz"
(|>) :: Queue a -> a -> Queue a
Queue a
q |> :: forall a. Queue a -> a -> Queue a
|> a
x = a -> Queue a -> Queue a
forall a. a -> Queue a -> Queue a
snoc a
x Queue a
q
{-# INLINE (|>) #-}

-- | Fold over elements in the order they would be returned by pop
--
-- >>> toList (fromList "abc")
-- "abc"
instance Foldable Queue where
  null :: forall a. Queue a -> Bool
null      (Queue [a]
l [a]
_ Int
_) = [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
l
  length :: forall a. Queue a -> Int
length    (Queue [a]
l [a]
r Int
_) = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
r
  elem :: forall a. Eq a => a -> Queue a -> Bool
elem a
x    (Queue [a]
l [a]
r Int
_) = a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
x [a]
l Bool -> Bool -> Bool
|| a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
x [a]
r
  sum :: forall a. Num a => Queue a -> a
sum       (Queue [a]
l [a]
r Int
_) = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a]
l a -> a -> a
forall a. Num a => a -> a -> a
+ [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a]
r
  foldMap :: forall m a. Monoid m => (a -> m) -> Queue a -> m
foldMap a -> m
_ (Queue [] [a]
_ Int
_) = m
forall a. Monoid a => a
mempty
  foldMap a -> m
f (Queue (a
x:[a]
l) [a]
r Int
0) = a -> m
f a
x m -> m -> m
forall a. Semigroup a => a -> a -> a
<> [a] -> [a] -> m
rot [a]
l [a]
r
    where
      rot :: [a] -> [a] -> m
rot []     (a
y:[a]
_ ) = a -> m
f a
y
      rot (a
x:[a]
xs) (a
y:[a]
ys) = a -> m
f a
x m -> m -> m
forall a. Semigroup a => a -> a -> a
<> [a] -> [a] -> m
rot [a]
xs [a]
ys m -> m -> m
forall a. Semigroup a => a -> a -> a
<> a -> m
f a
y
      rot [a]
_      [a]
_      = [Char] -> m
forall a. HasCallStack => [Char] -> a
error [Char]
"PANIC: Advent.Queue invariant violated"
  foldMap a -> m
f (Queue (a
x:[a]
l) [a]
r Int
i) = a -> m
f a
x m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (a -> m) -> Queue a -> m
forall m a. Monoid m => (a -> m) -> Queue a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f ([a] -> [a] -> Int -> Queue a
forall a. [a] -> [a] -> Int -> Queue a
Queue [a]
l [a]
r (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))


-- | Renders using 'fromList' syntax.
--
-- >>> show (fromList "example")
-- "fromList \"example\""
instance Show a => Show (Queue a) where
  showsPrec :: Int -> Queue a -> ShowS
showsPrec Int
p Queue a
q
    = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11)
    (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [Char] -> ShowS
showString [Char]
"fromList "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> ShowS
forall a. Show a => a -> ShowS
shows (Queue a -> [a]
forall a. Queue a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Queue a
q)

-- >>> read "fromList \"example\"" :: Queue Char
-- fromList "example"
instance Read a => Read (Queue a) where
  readsPrec :: Int -> ReadS (Queue a)
readsPrec Int
prec
    = Bool -> ReadS (Queue a) -> ReadS (Queue a)
forall a. Bool -> ReadS a -> ReadS a
readParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11) (ReadS (Queue a) -> ReadS (Queue a))
-> ReadS (Queue a) -> ReadS (Queue a)
forall a b. (a -> b) -> a -> b
$ \[Char]
str ->
      do ([Char]
"fromList", [Char]
str) <- ReadS [Char]
lex [Char]
str
         ([a]
xs,         [Char]
str) <- ReadS [a]
forall a. Read a => ReadS a
reads [Char]
str
         (Queue a, [Char]) -> [(Queue a, [Char])]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Queue a
forall a. [a] -> Queue a
fromList [a]
xs, [Char]
str)

-- | Construct a queue from a single element.
--
-- >>> singleton 'a'
-- fromList "a"
singleton :: a -> Queue a
singleton :: forall a. a -> Queue a
singleton a
x = [a] -> [a] -> Int -> Queue a
forall a. [a] -> [a] -> Int -> Queue a
Queue [a
x] [] Int
1

-- | Construct a queue from a list. The head of the list will
-- be the first element returned by 'pop'
fromList :: [a] -> Queue a
fromList :: forall a. [a] -> Queue a
fromList [a]
xs = [a] -> [a] -> Int -> Queue a
forall a. [a] -> [a] -> Int -> Queue a
Queue [a]
xs [] ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs)

-- | Append many items onto a queue. The items will pop from the queue
-- in the same order as they are in the given list.
--
-- >>> appendList (fromList "xyz") "abc" 
-- fromList "xyzabc"
appendList :: Queue a -> [a] -> Queue a
appendList :: forall a. Queue a -> [a] -> Queue a
appendList = (Queue a -> a -> Queue a) -> Queue a -> [a] -> Queue a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Queue a -> a -> Queue a
forall a. Queue a -> a -> Queue a
(|>)

-- | Remove an element from the front of a queue and a new queue
-- without that element.
--
-- >>> pop (fromList "abc")
-- Just ('a',fromList "bc")
pop :: Queue a -> Maybe (a, Queue a)
pop :: forall a. Queue a -> Maybe (a, Queue a)
pop (Queue (a
x:[a]
f) [a]
r Int
s) = (a, Queue a) -> Maybe (a, Queue a)
forall a. a -> Maybe a
Just (a
x, [a] -> [a] -> Int -> Queue a
forall a. [a] -> [a] -> Int -> Queue a
exec [a]
f [a]
r Int
s)
pop Queue a
_                 = Maybe (a, Queue a)
forall a. Maybe a
Nothing

-- | Add a new element to the end of a queue.
--
-- >>> snoc 'z' (fromList "abc")
-- fromList "abcz"
snoc :: a -> Queue a -> Queue a
snoc :: forall a. a -> Queue a -> Queue a
snoc a
x (Queue [a]
f [a]
r Int
s) = [a] -> [a] -> Int -> Queue a
forall a. [a] -> [a] -> Int -> Queue a
exec [a]
f (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
r) Int
s

exec :: [a] -> [a] -> Int -> Queue a
exec :: forall a. [a] -> [a] -> Int -> Queue a
exec [a]
f [a]
r Int
0    = [a] -> Queue a
forall a. [a] -> Queue a
fromList ([a] -> [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a] -> [a]
rotate [a]
f [a]
r [])
exec [a]
f [a]
r Int
i = [a] -> [a] -> Int -> Queue a
forall a. [a] -> [a] -> Int -> Queue a
Queue [a]
f [a]
r (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

rotate :: [a] -> [a] -> [a] -> [a]
rotate :: forall a. [a] -> [a] -> [a] -> [a]
rotate []     (a
y:[a]
_ ) [a]
a = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
a
rotate (a
x:[a]
xs) (a
y:[a]
ys) [a]
a = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a] -> [a]
rotate [a]
xs [a]
ys (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
a)
rotate [a]
_      [a]
_      [a]
_ = [Char] -> [a]
forall a. HasCallStack => [Char] -> a
error [Char]
"Advent.Queue.rotate: panic"