-- | A queue data structure with \(\mathcal{O}(1)\) (worst-case) operations, as described in
--
--   * Okasaki, Chris. \"Simple and efficient purely functional queues and deques.\" /Journal of functional programming/ 5.4 (1995): 583-592.
--   * Okasaki, Chris. /Purely Functional Data Structures/. Diss. Princeton University, 1996.
module Queue
  ( -- * Queue
    Queue (Empty, Full),

    -- ** Initialization
    empty,
    singleton,
    fromList,

    -- * Basic interface
    enqueue,
    dequeue,

    -- ** Extended interface
    enqueueFront,

    -- * Queries
    isEmpty,

    -- * Transformations
    map,
    traverse,

    -- * Conversions
    toList,
  )
where

import Data.Foldable qualified as Foldable
import Data.List qualified as List
import Data.Traversable qualified as Traversable
import GHC.Exts (Any)
import Unsafe.Coerce (unsafeCoerce)
import Prelude hiding (foldMap, length, map, span, traverse)

------------------------------------------------------------------------------------------------------------------------
-- Queue type and instances

-- | A queue data structure with \(\mathcal{O}(1)\) (worst-case) operations.
data Queue a
  = Q
      -- The front of the queue.
      -- Invariant: not shorter than the back
      [a]
      -- The back of the queue, in reverse order.
      [a]
      -- Some tail of the front of the queue.
      -- Invariant: length = length of front - length of back
      Schedule
  -- fmap loses exact sharing of front of queue and schedule, but the schedule still works, forcing cons cells of the
  -- original front (before fmap)
  deriving stock ((forall a b. (a -> b) -> Queue a -> Queue b)
-> (forall a b. a -> Queue b -> Queue a) -> Functor Queue
forall a b. a -> Queue b -> Queue a
forall a b. (a -> b) -> Queue a -> Queue b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Queue a -> Queue b
fmap :: forall a b. (a -> b) -> Queue a -> Queue b
$c<$ :: forall a b. a -> Queue b -> Queue a
<$ :: forall a b. a -> Queue b -> Queue a
Functor)

instance (Eq a) => Eq (Queue a) where
  (==) :: Queue a -> Queue a -> Bool
  Queue a
xs == :: Queue a -> Queue a -> Bool
== Queue a
ys =
    Queue a -> [a]
forall a. Queue a -> [a]
Queue.toList Queue a
xs [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== Queue a -> [a]
forall a. Queue a -> [a]
Queue.toList Queue a
ys

instance Foldable Queue where
  foldMap :: (Monoid m) => (a -> m) -> Queue a -> m
  foldMap :: forall m a. Monoid m => (a -> m) -> Queue a -> m
foldMap a -> m
f =
    Queue a -> m
go
    where
      go :: Queue a -> m
go = \case
        Queue a
Empty -> m
forall a. Monoid a => a
mempty
        Full a
x Queue a
xs -> a -> m
f a
x m -> m -> m
forall a. Semigroup a => a -> a -> a
<> Queue a -> m
go Queue a
xs

  null :: Queue a -> Bool
  null :: forall a. Queue a -> Bool
null =
    Queue a -> Bool
forall a. Queue a -> Bool
isEmpty

  toList :: Queue a -> [a]
  toList :: forall a. Queue a -> [a]
toList =
    Queue a -> [a]
forall a. Queue a -> [a]
Queue.toList

instance Monoid (Queue a) where
  mempty :: Queue a
  mempty :: Queue a
mempty =
    Queue a
forall a. Queue a
empty

-- | \(\mathcal{O}(n)\), where \(n\) is the size of the second argument.
instance Semigroup (Queue a) where
  (<>) :: Queue a -> Queue a -> Queue a
  Queue a
xs <> :: Queue a -> Queue a -> Queue a
<> Queue a
Empty = Queue a
xs
  Queue a
xs <> Full a
y Queue a
ys = a -> Queue a -> Queue a
forall a. a -> Queue a -> Queue a
enqueue a
y Queue a
xs Queue a -> Queue a -> Queue a
forall a. Semigroup a => a -> a -> a
<> Queue a
ys

instance (Show a) => Show (Queue a) where
  show :: Queue a -> String
  show :: Queue a -> String
show =
    [a] -> String
forall a. Show a => a -> String
show ([a] -> String) -> (Queue a -> [a]) -> Queue a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Queue a -> [a]
forall a. Queue a -> [a]
Queue.toList

instance Traversable Queue where
  traverse :: (Applicative f) => (a -> f b) -> Queue a -> f (Queue b)
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Queue a -> f (Queue b)
traverse =
    (a -> f b) -> Queue a -> f (Queue b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Queue a -> f (Queue b)
Queue.traverse

------------------------------------------------------------------------------------------------------------------------
-- Patterns

-- | An empty queue.
pattern Empty :: Queue a
pattern $mEmpty :: forall {r} {a}. Queue a -> ((# #) -> r) -> ((# #) -> r) -> r
Empty <- (dequeue -> Nothing)

-- | The front of a queue, and the rest of it.
pattern Full :: a -> Queue a -> Queue a
pattern $mFull :: forall {r} {a}. Queue a -> (a -> Queue a -> r) -> ((# #) -> r) -> r
Full x xs <- (dequeue -> Just (x, xs))

{-# COMPLETE Empty, Full #-}

------------------------------------------------------------------------------------------------------------------------
-- Internal smart constructor utils

-- `queue xs ys schedule` is always called when |schedule| = |xs| - |ys| + 1 (i.e. just after a enqueue or dequeue)
makeQueue :: [a] -> [a] -> Schedule -> Queue a
makeQueue :: forall a. [a] -> [a] -> Schedule -> Queue a
makeQueue [a]
xs [a]
ys = \case
  Schedule
Z -> [a] -> Queue a
forall a. [a] -> Queue a
Queue.fromList ([a] -> [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a] -> [a]
rotate [a]
xs [a]
ys [])
  S Schedule
schedule -> [a] -> [a] -> Schedule -> Queue a
forall a. [a] -> [a] -> Schedule -> Queue a
Q [a]
xs [a]
ys Schedule
schedule

-- rotate xs ys zs = xs ++ reverse ys ++ zs
-- Precondition: |ys| = |xs| + 1
rotate :: [a] -> NonEmptyList a -> [a] -> [a]
rotate :: forall a. [a] -> [a] -> [a] -> [a]
rotate [] (a
y :| [a]
_) [a]
zs = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
zs
rotate (a
x : [a]
xs) (a
y :| [a]
ys) [a]
zs = 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
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
zs)

------------------------------------------------------------------------------------------------------------------------
-- Initialization

-- | An empty queue.
empty :: Queue a
empty :: forall a. Queue a
empty =
  [a] -> [a] -> Schedule -> Queue a
forall a. [a] -> [a] -> Schedule -> Queue a
Q [] [] Schedule
Z

-- | A singleton queue.
singleton :: a -> Queue a
singleton :: forall a. a -> Queue a
singleton a
x =
  [a] -> Queue a
forall a. [a] -> Queue a
Queue.fromList [a
x]

-- | \(\mathcal{O}(1)\). Construct a queue from a list. The head of the list corresponds to the front of the queue.
fromList :: [a] -> Queue a
fromList :: forall a. [a] -> Queue a
fromList [a]
xs =
  [a] -> [a] -> Schedule -> Queue a
forall a. [a] -> [a] -> Schedule -> Queue a
Q [a]
xs [] ([a] -> Schedule
forall a b. a -> b
unsafeCoerce [a]
xs)

------------------------------------------------------------------------------------------------------------------------
-- Basic interface

-- | \(\mathcal{O}(1)\). Enqueue an element at the back of a queue, to be dequeued last.
enqueue :: a -> Queue a -> Queue a
enqueue :: forall a. a -> Queue a -> Queue a
enqueue a
y (Q [a]
xs [a]
ys Schedule
schedule) =
  [a] -> [a] -> Schedule -> Queue a
forall a. [a] -> [a] -> Schedule -> Queue a
makeQueue [a]
xs (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys) Schedule
schedule

-- | \(\mathcal{O}(1)\) front, \(\mathcal{O}(1)\) rest. Dequeue an element from the front of a queue.
dequeue :: Queue a -> Maybe (a, Queue a)
dequeue :: forall a. Queue a -> Maybe (a, Queue a)
dequeue = \case
  Q [] [a]
_ Schedule
_ -> Maybe (a, Queue a)
forall a. Maybe a
Nothing
  Q (a
x : [a]
xs) [a]
ys Schedule
schedule -> (a, Queue a) -> Maybe (a, Queue a)
forall a. a -> Maybe a
Just (a
x, [a] -> [a] -> Schedule -> Queue a
forall a. [a] -> [a] -> Schedule -> Queue a
makeQueue [a]
xs [a]
ys Schedule
schedule)

------------------------------------------------------------------------------------------------------------------------
-- Extended interface

-- | \(\mathcal{O}(1)\). Enqueue an element at the front of a queue, to be dequeued next.
enqueueFront :: a -> Queue a -> Queue a
enqueueFront :: forall a. a -> Queue a -> Queue a
enqueueFront a
x (Q [a]
xs [a]
ys Schedule
schedule) =
  -- smart constructor not needed here
  -- we also add useless work to the schedule to maintain the convenient rotate-on-empty-schedule trigger
  [a] -> [a] -> Schedule -> Queue a
forall a. [a] -> [a] -> Schedule -> Queue a
Q (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs) [a]
ys (a -> Any
forall a b. a -> b
unsafeCoerce a
x Any -> Schedule -> Schedule
forall a. a -> [a] -> [a]
: Schedule
schedule)

------------------------------------------------------------------------------------------------------------------------
-- Queries

-- | \(\mathcal{O}(1)\). Is a queue empty?
isEmpty :: Queue a -> Bool
isEmpty :: forall a. Queue a -> Bool
isEmpty = \case
  Q [] [a]
_ Schedule
_ -> Bool
True
  Queue a
_ -> Bool
False

------------------------------------------------------------------------------------------------------------------------
-- Transformations

-- | \(\mathcal{O}(n)\). Apply a function to every element in a queue.
map :: (a -> b) -> Queue a -> Queue b
map :: forall a b. (a -> b) -> Queue a -> Queue b
map =
  (a -> b) -> Queue a -> Queue b
forall a b. (a -> b) -> Queue a -> Queue b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

-- | \(\mathcal{O}(n)\). Apply a function to every element in a queue.
traverse :: (Applicative f) => (a -> f b) -> Queue a -> f (Queue b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Queue a -> f (Queue b)
traverse a -> f b
f =
  -- FIXME can we do better here?
  ([b] -> Queue b) -> f [b] -> f (Queue b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [b] -> Queue b
forall a. [a] -> Queue a
fromList (f [b] -> f (Queue b))
-> (Queue a -> f [b]) -> Queue a -> f (Queue b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> [a] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
Traversable.traverse a -> f b
f ([a] -> f [b]) -> (Queue a -> [a]) -> Queue a -> f [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Queue a -> [a]
forall a. Queue a -> [a]
toList

------------------------------------------------------------------------------------------------------------------------
-- Conversions

-- | \(\mathcal{O}(n)\). Construct a list from a queue. The head of the list corresponds to the front of the queue.
toList :: Queue a -> [a]
toList :: forall a. Queue a -> [a]
toList =
  (Queue a -> Maybe (a, Queue a)) -> Queue a -> [a]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
List.unfoldr Queue a -> Maybe (a, Queue a)
forall a. Queue a -> Maybe (a, Queue a)
dequeue

------------------------------------------------------------------------------------------------------------------------
-- Schedule utils

type Schedule =
  [Any]

pattern Z :: Schedule
pattern $mZ :: forall {r}. Schedule -> ((# #) -> r) -> ((# #) -> r) -> r
$bZ :: Schedule
Z = []

pattern S :: Schedule -> Schedule
pattern $mS :: forall {r}. Schedule -> (Schedule -> r) -> ((# #) -> r) -> r
S xs <- _ : xs

{-# COMPLETE Z, S #-}

------------------------------------------------------------------------------------------------------------------------
-- Non-empty list utils

-- A list that we know is non-empty somehow.
type NonEmptyList a =
  [a]

pattern (:|) :: a -> [a] -> NonEmptyList a
pattern $m:| :: forall {r} {a}.
NonEmptyList a -> (a -> NonEmptyList a -> r) -> ((# #) -> r) -> r
$b:| :: forall a. a -> [a] -> [a]
(:|) x xs = x : xs

{-# COMPLETE (:|) #-}