Okasaki PFDS Haskell code

BankersDeque.hs

-- Source code from
--   Purely Functional Data Structures
--   Chris Okasaki
--   Cambridge University Press, 1998
--
-- Copyright (c) 1998 Cambridge University Press

module BankersDeque (module Deque, BankersDeque, showBD) where
import Prelude hiding (head,tail,last,init)
import Data.List (intercalate)
import NestedShowable (NestedShowable (showNested))
import Deque

c :: Int
c = 3

data BankersDeque a = BD Int [a] Int [a] deriving (Show)

showBD :: (a -> String) -> BankersDeque a -> String
showBD f (BD xsz x ysz y) =
    show xsz ++ " " ++ "(" ++ intercalate "," (map f x) ++ ") " ++
    show ysz ++ " " ++ "(" ++ intercalate "," (map f y) ++ "))"

instance NestedShowable BankersDeque where
    showNested = showBD

check :: Int -> [a] -> Int -> [a] -> BankersDeque a
check lenf f lenr r
    | lenf > c*lenr + 1 =
      let i = (lenf+lenr) `div` 2
          j = lenf+lenr-i
          f' = take i f
          r' = r ++ reverse (drop i f)
      in BD i f' j r'
    | lenr > c*lenf + 1 =
      let j = (lenf+lenr) `div` 2
          i = lenf+lenr-j
          r' = take j r
          f' = f ++ reverse (drop j r)
      in BD i f' j r'
    | otherwise = BD lenf f lenr r

instance Deque BankersDeque where
  empty = BD 0 [] 0 []
  isEmpty (BD lenf _ lenr _) = lenf+lenr == 0

  cons x (BD lenf f lenr r) = check (lenf+1) (x:f) lenr r

  head (BD _    []    _    _) = error "BankersDeque.head: empty deque"
  head (BD _    (x:_) _    _) = x

  tail (BD _    []     _    _) = error "BankersDeque.tail: empty deque"
  tail (BD lenf (_:f') lenr r) = check (lenf-1) f' lenr r

  snoc (BD lenf f lenr r) x = check lenf f (lenr+1) (x:r)

  last (BD _    _ _     [])    = error "BankersDeque.last: empty deque"
  last (BD _    _ _     (x:_)) = x

  init (BD _    _ _    [])     = error "BankersDeque.init: empty deque"
  init (BD lenf f lenr (_:r')) = check lenf f (lenr-1) r'

CatenableDeque.hs

-- Source code from
--   Purely Functional Data Structures
--   Chris Okasaki
--   Cambridge University Press, 1998
--
-- Copyright (c) 1998 Cambridge University Press

module CatenableDeque (module Deque,CatenableDeque(..)) where
import Prelude hiding (head,tail,last,init,(++))
import Deque

class Deque q => CatenableDeque q where
  (++) :: q a -> q a -> q a

Deque.hs

-- Source code from
--   Purely Functional Data Structures
--   Chris Okasaki
--   Cambridge University Press, 1998
--
-- Copyright (c) 1998 Cambridge University Press

module Deque (Deque(..)) where
import Prelude hiding (head,tail,last,init)

class Deque q where
  empty   :: q a
  isEmpty :: q a -> Bool

  cons    :: a -> q a -> q a
  head    :: q a -> a
  tail    :: q a -> q a

  snoc    :: q a -> a -> q a
  last    :: q a -> a
  init    :: q a -> q a

Example.hs

{-# LANGUAGE
    FlexibleInstances
 #-}
import Prelude hiding ((++))

import BankersDeque (BankersDeque)
import Data.Monoid ((<>))
import SimpleCatenableDeque

instance Show a => Show (SimpleCatDeque BankersDeque a) where
  show val = case val of
      Shallow wrapped -> "(Shallow (" <> show wrapped <> "))"
      Deep left child right -> "(Deep " <>
        "(" <> show left <> ") " <>
        "(" <> show child <> ") " <>
        "(" <> show right <> "))"

hoopy :: SimpleCatDeque BankersDeque Int
hoopy = empty

hoh :: SimpleCatDeque BankersDeque Int
hoh = (5 `cons` hoopy) `snoc` 15

huao :: SimpleCatDeque BankersDeque Int
huao = hoh ++ hoh

main :: IO ()
main = do
    print hoh
    print huao
    return ()

NestedShowable.hs

module NestedShowable(NestedShowable (..)) where

class NestedShowable n where
    showNested :: (a -> String) -> n a -> String

SimpleCatenableDeque.hs

{-# LANGUAGE
    FlexibleContexts
  , FlexibleInstances
  , GADTs
  , GADTSyntax
  , ImpredicativeTypes
  , RankNTypes
  , ScopedTypeVariables
 #-}
-- Source code from
--   Purely Functional Data Structures
--   Chris Okasaki
--   Cambridge University Press, 1998
--
-- Copyright (c) 1998 Cambridge University Press

module SimpleCatenableDeque (module CatenableDeque,SimpleCatDeque(..),showSCD) where
import Prelude hiding (head,tail,last,init,(++))
import Data.Monoid ((<>))
import NestedShowable (NestedShowable (..))
import CatenableDeque

data SimpleCatDeque d a =
    Shallow (d a)
  | Deep (d a) (SimpleCatDeque d (d a)) (d a)

-- with UndecidableInstances, the following compiles, but attempts to show will
-- result in a context reduction stack overflow
{-
deriving instance (Show (d a), Show (SimpleCatDeque d (d a)))
  => Show (SimpleCatDeque d a)
-}

showSCD :: NestedShowable d => (a -> String) -> SimpleCatDeque d a -> String
showSCD f q = case q of
  Shallow wrapped -> "(Shallow (" <> showNested f wrapped <> "))"
  Deep left middle right -> "(Deep " <>
      "(" <> showNested f left <> ") " <>
      "(" <> showSCD (showNested f) middle <> ") " <>
      "(" <> showNested f right <> "))"

tooSmall :: Deque q => q a -> Bool
tooSmall d = isEmpty d || isEmpty (tail d)

dappendL :: (Deque q1, Deque q) => q1 a -> q a -> q a
dappendL d1 d2 = if isEmpty d1 then d2 else cons (head d1) d2


dappendR :: (Deque q1, Deque q) => q a -> q1 a -> q a
dappendR d1 d2 = if isEmpty d2 then d1 else snoc d1 (head d2)

instance Deque d => Deque (SimpleCatDeque d) where
  empty = Shallow empty
  isEmpty (Shallow d) = isEmpty d
  isEmpty _ = False

  cons x (Shallow d) = Shallow (cons x d)
  cons x (Deep f m r) = Deep (cons x f) m r

  head (Shallow d) = head d
  head (Deep f _ _) = head f

  tail (Shallow d) = Shallow (tail d)
  tail (Deep f m r)
      | not (tooSmall f') = Deep f' m r
      | isEmpty m = Shallow (dappendL f' r)
      | otherwise = Deep (dappendL f' (head m)) (tail m) r
    where f' = tail f

  snoc (Shallow d) x = Shallow (snoc d x)
  snoc (Deep f m r) x = Deep f m (snoc r x)

  last (Shallow d) = last d
  last (Deep _ _ r) = last r

  init (Shallow d) = Shallow (init d)
  init (Deep f m r)
      | not (tooSmall r') = Deep f m r'
      | isEmpty m = Shallow (dappendR f r')
      | otherwise = Deep f (init m) (dappendR (last m) r')
    where r' = init r

instance Deque d => CatenableDeque (SimpleCatDeque d) where
  (Shallow d1) ++ (Shallow d2)
      | tooSmall d1 = Shallow (dappendL d1 d2)
      | tooSmall d2 = Shallow (dappendR d1 d2)
      | otherwise = Deep d1 empty d2
  (Shallow d) ++ (Deep f m r)
      | tooSmall d = Deep (dappendL d f) m r
      | otherwise = Deep d (cons f m) r
  (Deep f m r) ++ (Shallow d)
      | tooSmall d = Deep f m (dappendR r d)
      | otherwise = Deep f (snoc m r) d
  (Deep f1 m1 r1) ++ (Deep f2 m2 r2) = Deep f1 (snoc m1 r1 ++ cons f2 m2) r2