Adding Deques

Author: Divesh-Otwani

linear-base.cabal

@@ -40,6 +40,7 @@ library
     Data.Bifunctor.Linear.Internal.Bifunctor
     Data.Bifunctor.Linear.Internal.SymmetricMonoidal
     Data.Bool.Linear
+    Data.Deque.Mutable.Linear
     Data.Either.Linear
     Data.Functor.Linear
     Data.Functor.Linear.Internal.Functor

src/Data/Deque/Mutable/Linear.hs

@@ -0,0 +1,182 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Mutable Linear Deque
+--
+-- This module provides a pure interface to a mutable deque.
+--
+-- It is designed to be imported qualfied:
+--
+-- > import qualfied Data.Deque.Mutable.Linear as Deque
+module Data.Deque.Mutable.Linear
+  (
+  -- * Allocation
+    alloc
+  , fromList
+  -- * Querying
+  , size
+  , length
+  , isFull
+  , peekRight
+  , peekLeft
+  -- * Modification
+  , addLeft
+  , addRight
+  , popLeft
+  , popRight
+  , map
+  -- * Consumption
+  , toList
+  )
+where
+
+import qualified Data.Array.Mutable.Linear as Array
+import Data.Unrestricted.Linear
+import Prelude.Linear hiding (length, map)
+import qualified Prelude
+import GHC.Stack
+
+
+-- # Types
+-------------------------------------------------------------------------------
+
+data Deque a where
+  Deque :: Int -> Maybe (Int,Int) -> !(Array.Array a) %1-> Deque a
+  -- This is: Deque size (Maybe (left ptr,right ptr)) array
+  --
+  -- The deque is represented as a slice from the left pointer
+  -- moving forwards (and wrapping the end) to the right pointer.
+  -- We are full when the right pointer is one less than the left pointer
+  -- modulo the array size. An empty deque has no left or right pointers
+  -- and we start a singleton deque with both pointers at 0.
+  --
+  -- Invariants:
+  -- > If empty, we store no pointers
+  -- > The first int is the size of the array
+  -- > If we store pointers l,r then [arr[l], ... arr[r]] is the deque
+
+data Dir = L | R -- A left or right direction
+
+-- # Internal Helpers
+-------------------------------------------------------------------------------
+
+-- Given a size, get the next index
+nextIx :: Int -> Int -> Int
+nextIx sz ix = (ix + 1) `mod` sz
+
+-- Given a size, get the previous index
+prevIx :: Int -> Int -> Int
+prevIx sz ix = (ix - 1 + sz) `mod` sz
+
+-- # Allocation
+-------------------------------------------------------------------------------
+
+-- | Run a computation of an empty Deque with a given size
+alloc :: HasCallStack => Int -> (Deque a %1-> Ur b) %1-> Ur b
+alloc k f = Array.alloc k err $ \arr -> f (Deque k Nothing arr) where
+  err = Prelude.error "Accessing error element of a collection!"
+
+-- | Run a computation on a Deque that is deterimined by the given the list
+-- where we treat the start and end of the list as the left and right pointers,
+-- with the total capacity as the length of the list.
+fromList :: [a] -> (Deque a %1-> Ur b) %1-> Ur b
+fromList xs f | l <- Prelude.length xs = Array.fromList xs $
+  \arr -> f (Deque l (Just (0,l-1)) arr)
+
+
+-- # Querying
+-------------------------------------------------------------------------------
+
+-- | The total capacity of the Deque
+size :: Deque a %1-> (Ur Int, Deque a)
+size (Deque sz ptrs arr) = (Ur sz, Deque sz ptrs arr)
+
+-- | The number of elements currently stored
+length :: Deque a %1-> (Ur Int, Deque a)
+length (Deque sz Nothing arr) = (Ur 0, Deque sz Nothing arr)
+length (Deque sz p@(Just (l,r)) arr)
+  | l <= r = (Ur (1 + r - l), Deque sz p arr)
+  | otherwise = (Ur (sz + 1 - l + r), Deque sz p arr)
+
+-- | We are full if the length equals the size
+isFull :: Deque a %1-> (Ur Bool, Deque a)
+isFull d =
+  length d & \(Ur len, Deque sz p arr) -> (Ur (len == sz), Deque sz p arr)
+
+peek :: HasCallStack => Dir -> Deque a %1-> (Ur a, Deque a)
+peek _ (Deque _ Nothing arr) = error "Peeking in empty deque." $ arr
+peek dir (Deque sz p@(Just (l,r)) arr) = case dir of
+  L -> Array.read arr l & \(x, arr') -> (x, Deque sz p arr')
+  R -> Array.read arr r & \(x, arr') -> (x, Deque sz p arr')
+
+-- | View the top of the left queue
+peekLeft :: HasCallStack => Deque a %1-> (Ur a, Deque a)
+peekLeft = peek L
+
+-- | View the top of the right queue
+peekRight :: HasCallStack => Deque a %1-> (Ur a, Deque a)
+peekRight = peek R
+
+
+-- # Modification
+-------------------------------------------------------------------------------
+
+add :: HasCallStack => Dir -> Deque a %1-> a -> Deque a
+add dir deq x = isFull deq & \case
+  (Ur True, deq') -> error "Adding to a full deque" $ deq'
+  (Ur False, Deque sz Nothing arr) ->
+    Deque sz (Just (0,0)) (Array.write arr 0 x)
+  (Ur False, Deque sz (Just (l,r)) arr) -> case dir of
+    L -> Array.write arr (prevIx sz l) x &
+      \arr' -> Deque sz (Just (prevIx sz l, r)) arr'
+    R -> Array.write arr (nextIx sz r) x &
+      \arr' -> Deque sz (Just (l,nextIx sz r)) arr'
+
+-- | Add to the left queue
+addLeft :: HasCallStack => Deque a %1-> a -> Deque a
+addLeft = add L
+
+-- | Add to the right queue
+addRight :: HasCallStack => Deque a %1-> a -> Deque a
+addRight = add R
+
+pop :: HasCallStack => Dir -> Deque a %1-> Deque a
+pop _ (Deque _ Nothing arr) = error "Popping from empty deque." $ arr
+pop dir (Deque sz (Just (l,r)) arr)
+  | l==r = Deque sz Nothing arr
+  | otherwise = case dir of
+    L -> Deque sz (Just (nextIx sz l, r)) arr
+    R -> Deque sz (Just (l, prevIx sz r)) arr
+
+-- | Remove the last added element from the left queue
+popLeft :: HasCallStack => Deque a %1-> Deque a
+popLeft = pop L
+
+-- | Remove the last added element from the right queue
+popRight :: HasCallStack => Deque a %1-> Deque a
+popRight = pop R
+
+-- Note: We can't use a Prelude.Functor nor a Data.Functor
+-- because the mapped function need not be linear but we must
+-- consume the Deque linearly. The types don't align.
+map :: (a -> b) -> Deque a %1-> Deque b
+map f (Deque sz p arr) = Deque sz p (Array.map f arr)
+
+
+-- # Consumption
+-------------------------------------------------------------------------------
+
+-- | Convert the Deque to a list where the first element is the left
+-- top and the last element is the right top
+toList :: Deque a %1-> Ur [a]
+toList (Deque _ Nothing arr) = lseq arr (Ur [])
+toList (Deque sz (Just (l0,r0)) arr) = loop l0 r0 [] arr where
+  loop :: Int -> Int -> [a] -> Array.Array a %1-> Ur [a]
+  loop l r xs arr0
+    | l==r = Array.read arr0 r & \(Ur a, arr1) -> lseq arr1 (Ur (a:xs))
+    | otherwise = Array.read arr0 r & \(Ur a, arr1) ->
+        loop l (prevIx sz r) (a:xs) arr1
+

src/Data/Unrestricted/Internal/Instances.hs

@@ -196,6 +196,8 @@ instance Dupable (Ur a) where
 instance Movable (Ur a) where
   move (Ur a) = Ur (Ur a)
 
+deriving instance Prelude.Show a => Prelude.Show (Ur a)
+
 instance Prelude.Functor Ur where
   fmap f (Ur a) = Ur (f a)