Day 22 - part 1 finished, part 2 is 8 minutes off (i.e. one extra region travelled).

app/Main.hs

@@ -30,4 +30,4 @@ import qualified Day24
 import qualified Day25
 
 main :: IO ()
-main = Day21.main
+main = Day22.main

input/22.txt

@@ -0,0 +1,2 @@
+depth: 7305
+target: 13,734

src/Day22.hs

@@ -1,6 +1,92 @@
 module Day22 (main) where
 
+import Data.Foldable (foldl')
+import Data.Map.Strict (Map, (!), insert, member, empty)
+import Data.Set (Set, notMember)
+import qualified Data.Set as S (insert, fromList)
+import Data.Ix (range)
+import PSQueue (Binding(..), PSQ, minView, insertBindingWith, fromList)
+import Debug.Trace (traceShow)
+
+type ErosionLevels = Map Coordinate Int
+type Visiteds = Set Coordinate
+type Coordinate = (Int, Int) -- (x, y)
+type Queue = PSQ Key Int
+type Key = (Coordinate, Tool)
+data Tool = Torch | Climbing | Neither deriving (Eq, Ord, Show)
+
+depth  = 7305
+target = (13, 734) -- (x, y)
+erosionMod = 20183
+
+getErosionLevel :: (Int, ErosionLevels) -> Coordinate -> (Int, ErosionLevels)
+getErosionLevel (_, els) coord@(x, y) =
+    if   member coord els
+    then (els ! coord, els)
+    else calculated
+    where calculated
+            | coord == (0, 0) = (depth, insert coord depth els)
+            | coord == target = (depth, insert coord depth els)
+            | x == 0 =
+                let val = (y * 48271 + depth) `mod` erosionMod
+                in  (val, insert coord val els)
+            | y == 0 =
+                let val = (x * 16807 + depth) `mod` erosionMod
+                in  (val, insert coord val els)
+            | otherwise =
+                let (up,   upEls)    = getErosionLevel (0, els)   (x, y - 1)
+                    (left, rightEls) = getErosionLevel (0, upEls) (x - 1, y)
+                    val = (up * left + depth) `mod` erosionMod
+                in  (val, insert coord val rightEls)
+
+getRiskLevel :: ErosionLevels -> Coordinate -> (Int, ErosionLevels)
+getRiskLevel els coord =
+    let (val, els') = getErosionLevel (0, els) coord
+    in  (val `mod` 3, els')
+
+-- getBinding :: erosion levels -> source binding -> target coordinate -> (target binding, updated erosion levels)
+getBinding :: ErosionLevels -> Binding Key Int -> Coordinate -> (Binding Key Int, ErosionLevels) 
+getBinding els ((sCoord, sTool) :-> sTime) tCoord =
+    let (sType, sEls) = getRiskLevel els  sCoord
+        (tType, tEls) = getRiskLevel sEls tCoord
+        (time, tool)  = getTimeTool sType tType (sTime, sTool)
+    in  (if tCoord == target && tool /= Torch then (tCoord, Torch) :-> time + 7 else (tCoord, tool) :-> time, tEls)
+    where
+        getTimeTool :: Int -> Int -> (Int, Tool) -> (Int, Tool)
+        getTimeTool 0 2 (time, Climbing) = (time + 8, Torch)       -- rocky  -> narrow
+        getTimeTool 1 2 (time, Climbing) = (time + 8, Neither)     -- wet    -> narrow
+        getTimeTool 0 1 (time, Torch)    = (time + 8, Climbing)    -- rocky  -> wet
+        getTimeTool 2 1 (time, Torch)    = (time + 8, Neither)     -- narrow -> wet
+        getTimeTool 1 0 (time, Neither)  = (time + 8, Climbing)    -- wet    -> rocky
+        getTimeTool 2 0 (time, Neither)  = (time + 8, Torch)       -- narrow -> rocky
+        getTimeTool _ _ (time, tool)     = (time + 1, tool)
+
+getTargetTime :: Visiteds -> (Queue, ErosionLevels) -> Int
+getTargetTime vis (q, els) =
+    let Just (region@((coord, _) :-> time), q') = minView q
+        neighbours = getNeighbours coord
+    in  if   coord == target then time
+        else getTargetTime (S.insert coord vis) $ foldl' (insertCoord region) (q', els) neighbours
+    where
+        -- source binding -> (queue, erosion levels) -> target coordinate -> (queue with target binding, updated erosion levels)
+        insertCoord :: Binding Key Int -> (Queue, ErosionLevels) -> Coordinate -> (Queue, ErosionLevels)
+        insertCoord region (q, els) coord =
+            let (binding, els') = getBinding els region coord
+            in  (insertBindingWith min binding q, els')
+        getNeighbours :: (Int, Int) -> [(Int, Int)]
+        getNeighbours coord@(x, y) = filter (\coord@(x, y) -> x >= 0 && y >= 0 && notMember coord vis)
+            [(x - 1, y), (x, y - 1), (x + 1, y), (x, y + 1)]
+
+part1 :: Int
+part1 = sum . fmap (`mod` 3) . snd . foldl' getErosionLevel (0, empty) $ range ((0, 0), target)
+
+part2 :: Int
+part2 =
+    let q = fromList $ [((0, 0), Torch) :-> 0]
+        vis = S.fromList [(0, 0)]
+    in  getTargetTime vis (q, empty)
+
 main :: IO ()
 main = do
-    input <- readFile "input/22.txt"
+    print part1
-    print input
+    print part2

src/PSQueue.hs

@@ -0,0 +1,683 @@
+{- Copied from http://hackage.haskell.org/package/PSQueue-1.1/docs/src/Data-PSQueue.html -}
+
+{- |
+
+A /priority search queue/ (henceforth /queue/) efficiently supports the
+opperations of both a search tree and a priority queue. A 'Binding' is a
+product of a key and a priority. Bindings can be inserted, deleted, modified
+and queried in logarithmic time, and the binding with the least priority can be
+retrieved in constant time. A queue can be built from a list of bindings,
+sorted by keys, in linear time.
+
+This implementation is due to Ralf Hinze.
+
+* Hinze, R., /A Simple Implementation Technique for Priority Search Queues/, ICFP 2001, pp. 110-121
+
+<http://citeseer.ist.psu.edu/hinze01simple.html>
+
+-}
+
+-- Some modifications by Scott Dillard
+
+
+module PSQueue
+    ( 
+    -- * Binding Type
+    Binding((:->))
+    , key
+    , prio
+    -- * Priority Search Queue Type
+    , PSQ
+    -- * Query
+    , size
+    , null
+    , lookup
+    -- * Construction
+    , empty
+    , singleton
+    -- * Insertion
+    , insert
+    , insertWith
+    , insertWithKey
+    , insertBinding
+    , insertBindingWith
+    , insertBindingWithKey
+    -- * Delete/Update 
+    , delete
+    , adjust
+    , adjustWithKey
+    , update
+    , updateWithKey
+    , alter
+    -- * Conversion
+    , keys
+    , toList
+    , toAscList
+    , toDescList
+    , fromList
+    , fromAscList
+    , fromDistinctAscList
+    -- * Priority Queue
+    , findMin
+    , deleteMin
+    , minView
+    , atMost
+    , atMostRange
+    -- * Fold
+    , foldr
+    , foldl
+) where
+
+import Prelude hiding (lookup,null,foldl,foldr)
+import qualified Prelude as P
+
+{-
+-- testing
+import Test.QuickCheck
+import Data.List (sort)
+-}
+
+
+
+
+-- | @k :-> p@ binds the key @k@ with the priority @p@.
+data Binding k p = k :-> p deriving (Eq,Ord,Show,Read)
+
+infix 0 :->
+
+-- | The key of a binding
+key  :: Binding k p -> k
+key  (k :-> _) =  k
+
+-- | The priority of a binding
+prio :: Binding k p -> p
+prio (_ :-> p) =  p
+
+
+
+-- | A mapping from keys @k@ to priorites @p@. 
+
+data PSQ k p = Void | Winner k p (LTree k p) k
+
+instance (Show k, Show p, Ord k, Ord p) => Show (PSQ k p) where
+  show = show . toAscList
+  --show Void = "[]"
+  --show (Winner k1 p lt k2) = "Winner "++show k1++" "++show p++" ("++show lt++") "++show k2
+
+
+
+
+-- | /O(1)/ The number of bindings in a queue.
+size :: PSQ k p -> Int
+size Void = 0
+size (Winner _ _ lt _) = 1 + size' lt
+
+-- | /O(1)/ True if the queue is empty.
+null :: PSQ k p -> Bool
+null Void = True
+null (Winner _ _ _ _) = False
+
+-- | /O(log n)/ The priority of a given key, or Nothing if the key is not
+-- bound.
+lookup :: (Ord k, Ord p) => k -> PSQ k p -> Maybe p
+lookup k q = 
+  case tourView q of
+    Null -> fail "PSQueue.lookup: Empty queue"
+    Single k' p
+      | k == k'   -> return p
+      | otherwise -> fail "PSQueue.lookup: Key not found"
+    tl `Play` tr
+      | k <= maxKey tl -> lookup k tl
+      | otherwise      -> lookup k tr
+
+
+
+empty :: (Ord k, Ord p) => PSQ k p
+empty = Void
+
+-- | O(1) Build a queue with one binding.
+singleton :: (Ord k, Ord p) => k -> p -> PSQ k p
+singleton k p =  Winner k p Start k
+
+
+-- | /O(log n)/ Insert a Binding into the queue.
+insertBinding :: (Ord k, Ord p) => Binding k p -> PSQ k p -> PSQ k p
+insertBinding (k :-> p) q = insert k p q
+
+
+-- | /O(log n)/ Insert a binding into the queue.
+insert :: (Ord k, Ord p) => k -> p -> PSQ k p -> PSQ k p
+insert k p q = 
+  case tourView q of
+    Null -> singleton k p
+    Single k' p' ->
+      case compare k k' of
+        LT -> singleton k  p  `play` singleton k' p'
+        EQ -> singleton k  p
+        GT -> singleton k' p' `play` singleton k  p
+    tl `Play` tr
+      | k <= maxKey tl -> insert k p tl `play` tr
+      | otherwise      -> tl `play` insert k p tr
+
+
+-- | /O(log n)/ Insert a Binding with a combining function.
+insertBindingWith :: (Ord k, Ord p) => (p->p->p) -> Binding k p -> PSQ k p -> PSQ k p
+insertBindingWith f = insertBindingWithKey (\_ p p' -> f p p')
+
+-- | /O(log n)/ Insert a Binding with a combining function.
+insertBindingWithKey :: (Ord k, Ord p) => (k->p->p->p) -> Binding k p -> PSQ k p -> PSQ k p
+insertBindingWithKey f (k :-> p) q = insertWithKey f k p q
+
+-- | /O(log n)/ Insert a binding with a combining function. 
+insertWith :: (Ord k, Ord p) => (p->p->p) -> k -> p -> PSQ k p -> PSQ k p
+insertWith f = insertWithKey (\_ p p'-> f p p')
+
+-- | /O(log n)/ Insert a binding with a combining function. 
+insertWithKey :: (Ord k, Ord p) => (k->p->p->p) -> k -> p -> PSQ k p -> PSQ k p
+insertWithKey f k p q =  
+  case tourView q of
+    Null -> singleton k p
+    Single k' p' ->
+      case compare k k' of 
+        LT -> singleton k  p  `play` singleton k' p'
+        EQ -> singleton k  (f k p p')
+        GT -> singleton k' p' `play` singleton k  p
+    tl `Play` tr
+      | k <= maxKey tl -> insertWithKey f k p tl `unsafePlay` tr
+      | otherwise      -> tl `unsafePlay` insertWithKey f k p tr
+
+
+
+-- | /O(log n)/ Remove a binding from the queue.
+delete :: (Ord k, Ord p) => k -> PSQ k p -> PSQ k p
+delete k q = 
+  case tourView q of
+    Null -> empty
+    Single k' p
+      | k == k'   -> empty
+      | otherwise -> singleton k' p
+    tl `Play` tr
+      | k <= maxKey tl -> delete k tl `play` tr
+      | otherwise      -> tl `play` delete k tr
+
+-- | /O(log n)/ Adjust the priority of a key.
+adjust ::  (Ord p, Ord k) => (p -> p) -> k -> PSQ k p -> PSQ k p
+adjust f = adjustWithKey (\_ p -> f p)
+
+-- | /O(log n)/ Adjust the priority of a key.
+adjustWithKey :: (Ord k, Ord p) => (k -> p -> p) -> k -> PSQ k p -> PSQ k p
+adjustWithKey f k q =  
+  case tourView q of
+    Null -> empty
+    Single k' p
+      | k == k'   -> singleton k' (f k p)
+      | otherwise -> singleton k' p
+    tl `Play` tr
+      | k <= maxKey tl -> adjustWithKey f k tl `unsafePlay` tr
+      | otherwise      -> tl `unsafePlay` adjustWithKey f k tr
+
+
+-- | /O(log n)/ The expression (@update f k q@) updates the
+-- priority @p@ bound @k@ (if it is in the queue). If (@f p@) is 'Nothing',
+-- the binding is deleted. If it is (@'Just' z@), the key @k@ is bound
+-- to the new priority @z@.
+
+update :: (Ord k, Ord p) => (p -> Maybe p) -> k -> PSQ k p -> PSQ k p
+update f = updateWithKey (\_ p -> f p)
+
+-- | /O(log n)/. The expression (@updateWithKey f k q@) updates the
+-- priority @p@ bound @k@ (if it is in the queue). If (@f k p@) is 'Nothing',
+-- the binding is deleted. If it is (@'Just' z@), the key @k@ is bound
+-- to the new priority @z@.
+
+updateWithKey :: (Ord k, Ord p) => (k -> p -> Maybe p) -> k -> PSQ k p -> PSQ k p
+updateWithKey f k q =  
+  case tourView q of
+    Null -> empty
+    Single k' p 
+      | k==k' -> case f k p of
+                  Nothing -> empty
+                  Just p' -> singleton k p'
+      | otherwise -> singleton k' p
+    tl `Play` tr
+      | k <= maxKey tl -> updateWithKey f k tl `unsafePlay` tr
+      | otherwise      -> tl `unsafePlay` updateWithKey f k tr
+
+
+-- | /O(log n)/. The expression (@'alter' f k q@) alters the priority @p@ bound to @k@, or absence thereof.
+-- alter can be used to insert, delete, or update a priority in a queue.
+alter :: (Ord k, Ord p) => (Maybe p -> Maybe p) -> k -> PSQ k p -> PSQ k p
+alter f k q =
+  case tourView q of
+    Null -> 
+      case f Nothing of
+        Nothing -> empty
+        Just p  -> singleton k p
+    Single k' p 
+      | k == k'   ->  case f (Just p) of
+                        Nothing -> empty
+                        Just p' -> singleton k' p'
+      | otherwise ->  case f Nothing of
+                        Nothing -> singleton k' p
+                        Just p' -> insert k p' $ singleton k' p
+    tl `Play` tr
+      | k <= maxKey tl -> alter f k tl `unsafePlay` tr
+      | otherwise      -> tl `unsafePlay` alter f k tr
+
+
+
+-- | /O(n)/ The keys of a priority queue
+keys :: (Ord k, Ord p) => PSQ k p -> [k]
+keys = map key . toList
+
+-- | /O(n log n)/ Build a queue from a list of bindings.
+fromList :: (Ord k, Ord p) => [Binding k p] -> PSQ k p
+fromList = P.foldr (\(k:->p) q -> insert k p q) empty
+
+-- | /O(n)/ Build a queue from a list of bindings in order of
+-- ascending keys. The precondition that the keys are ascending is not checked.
+fromAscList :: (Ord k, Ord p) => [Binding k p] -> PSQ k p
+fromAscList = fromDistinctAscList . stripEq 
+  where stripEq []         = []
+        stripEq (x:xs)     = stripEq' x xs
+        stripEq' x' []     = [x']
+        stripEq' x' (x:xs) 
+          | x' == x   = stripEq' x' xs
+          | otherwise = x' : stripEq' x xs
+
+-- | /O(n)/ Build a queue from a list of distinct bindings in order of
+-- ascending keys. The precondition that keys are distinct and ascending is not checked.
+fromDistinctAscList :: (Ord k, Ord p) => [Binding k p] -> PSQ k p
+fromDistinctAscList = foldm unsafePlay empty . map (\(k:->p) -> singleton k p)
+
+-- Folding a list in a binary-subdivision scheme.
+foldm :: (a -> a -> a) -> a -> [a] -> a
+foldm (*) e x
+  | P.null  x             = e
+  | otherwise             = fst (rec (length x) x)
+  where rec 1 (a : as)    = (a, as)
+        rec n as          = (a1 * a2, as2)
+          where m         = n `div` 2
+                (a1, as1) = rec (n - m) as 
+                (a2, as2) = rec m       as1
+
+-- | /O(n)/ Convert a queue to a list.
+toList :: (Ord k, Ord p) => PSQ k p -> [Binding k p]
+toList = toAscList
+
+-- | /O(n)/ Convert a queue to a list in ascending order of keys.
+toAscList :: (Ord k, Ord p) => PSQ k p -> [Binding k p]
+toAscList q  = seqToList (toAscLists q)
+
+toAscLists :: (Ord k, Ord p) => PSQ k p -> Sequ (Binding k p)
+toAscLists q = case tourView q of
+  Null -> mempty
+  Single k p -> singleSequ (k :-> p)
+  tl `Play` tr -> toAscLists tl <> toAscLists tr
+
+-- | /O(n)/ Convert a queue to a list in descending order of keys.
+toDescList :: (Ord k, Ord p) => PSQ k p -> [ Binding k p ]
+toDescList q = seqToList (toDescLists q)
+
+toDescLists :: (Ord k, Ord p) => PSQ k p -> Sequ (Binding k p)
+toDescLists q = case tourView q of 
+  Null -> mempty
+  Single k p -> singleSequ (k :-> p)
+  tl `Play` tr -> toDescLists tr <> toDescLists tl
+
+
+-- | /O(1)/ The binding with the lowest priority.
+findMin :: (Ord k, Ord p) => PSQ k p -> Maybe (Binding k p)
+findMin Void             = Nothing
+findMin (Winner k p t m) = Just (k :-> p) 
+
+-- | /O(log n)/ Remove the binding with the lowest priority.
+deleteMin :: (Ord k, Ord p) => PSQ k p -> PSQ k p
+deleteMin Void             = Void
+deleteMin (Winner k p t m) = secondBest t m
+
+-- | /O(log n)/ Retrieve the binding with the least priority, and the rest of
+-- the queue stripped of that binding. 
+minView :: (Ord k, Ord p) => PSQ k p -> Maybe (Binding k p, PSQ k p)
+minView Void             = Nothing
+minView (Winner k p t m) = Just ( k :-> p , secondBest t m )
+
+secondBest :: (Ord k, Ord p) => LTree k p -> k -> PSQ k p
+secondBest Start _m = Void
+secondBest (LLoser _ k p tl m tr) m' = Winner k p tl m `play` secondBest tr m'
+secondBest (RLoser _ k p tl m tr) m' = secondBest tl m `play` Winner k p tr m'
+
+
+
+-- | /O(r(log n - log r)/ @atMost p q@ is a list of all the bindings in @q@ with
+-- priority less than @p@, in order of ascending keys.
+-- Effectively, 
+--
+-- @
+--   atMost p' q = filter (\\(k:->p) -> p<=p') . toList
+-- @
+atMost :: (Ord k, Ord p) => p -> PSQ k p -> [Binding k p]
+atMost pt q = seqToList (atMosts pt q)
+
+atMosts :: (Ord k, Ord p) => p -> PSQ k p -> Sequ (Binding k p)
+atMosts _pt Void  = mempty
+atMosts pt (Winner k p t _) =  prune k p t
+  where
+  prune k p t
+    | p > pt         = mempty
+    | otherwise      = traverse k p t
+  traverse k p Start = singleSequ (k :-> p)
+  traverse k p (LLoser _ k' p' tl _m tr) = prune k' p' tl <> traverse k p tr
+  traverse k p (RLoser _ k' p' tl _m tr) = traverse k p tl <> prune k' p' tr
+
+-- | /O(r(log n - log r))/ @atMostRange p (l,u) q@ is a list of all the bindings in
+-- @q@ with a priority less than @p@ and a key in the range @(l,u)@ inclusive.
+-- Effectively,
+-- 
+-- @
+--    atMostRange p' (l,u) q = filter (\\(k:->p) -> l<=k && k<=u ) . 'atMost' p'
+-- @
+atMostRange :: (Ord k, Ord p) => p -> (k, k) -> PSQ k p -> [Binding k p]
+atMostRange pt (kl, kr) q = seqToList (atMostRanges pt (kl, kr) q)
+
+atMostRanges :: (Ord k, Ord p) => p -> (k, k) -> PSQ k p -> Sequ (Binding k p)
+
+atMostRanges _pt _range Void = mempty
+atMostRanges pt range@(kl, kr) (Winner k p t _) = prune k p t
+  where
+  prune k p t
+    | p > pt    = mempty
+    | otherwise = traverse k p t
+  traverse k p Start
+    | k `inrange` range = singleSequ (k :-> p)
+    | otherwise         = mempty
+  traverse k p (LLoser _ k' p' tl m tr) =  
+    guard (kl <= m) (prune k' p' tl) <> guard (m <= kr) (traverse k p tr)
+  traverse k p (RLoser _ k' p' tl m tr) =  
+    guard (kl <= m) (traverse k p tl) <> guard (m <= kr) (prune k' p' tr)
+
+inrange :: (Ord a) => a -> (a, a) -> Bool
+a `inrange` (l, r)  =  l <= a && a <= r
+
+
+
+
+-- | Right fold over the bindings in the queue, in key order.
+foldr :: (Ord k,Ord p) => (Binding k p -> b -> b) -> b -> PSQ k p -> b
+foldr f z q = 
+  case tourView q of
+    Null -> z
+    Single k p -> f (k:->p) z
+    l`Play`r -> foldr f (foldr f z r) l
+    
+
+-- | Left fold over the bindings in the queue, in key order.
+foldl :: (Ord k,Ord p) => (b -> Binding k p -> b) -> b -> PSQ k p -> b
+foldl f z q = 
+  case tourView q of
+    Null -> z
+    Single k p -> f z (k:->p)
+    l`Play`r -> foldl f (foldl f z l) r
+
+
+
+
+-----------------------
+------- Internals -----
+----------------------
+
+type Size = Int
+
+data LTree k p = Start
+               | LLoser {-# UNPACK #-}!Size !k !p (LTree k p) !k (LTree k p)
+               | RLoser {-# UNPACK #-}!Size !k !p (LTree k p) !k (LTree k p)
+
+
+size' :: LTree k p -> Size
+size' Start                = 0
+size' (LLoser s _ _ _ _ _) = s
+size' (RLoser s _ _ _ _ _) = s
+
+left, right :: LTree a b -> LTree a b
+
+left  Start                   =  error "left: empty loser tree"
+left  (LLoser _ _ _ tl _ _ ) =  tl
+left  (RLoser _ _ _ tl _ _ ) =  tl
+
+right Start                   =  error "right: empty loser tree"
+right (LLoser _ _ _ _  _ tr) =  tr
+right (RLoser _ _ _ _  _ tr) =  tr
+
+maxKey :: PSQ k p -> k
+maxKey Void                =  error "maxKey: empty queue"
+maxKey (Winner _k _p _t m) =  m
+
+lloser, rloser :: k -> p -> LTree k p -> k -> LTree k p -> LTree k p
+lloser k p tl m tr =  LLoser (1 + size' tl + size' tr) k p tl m tr
+rloser k p tl m tr =  RLoser (1 + size' tl + size' tr) k p tl m tr
+
+--balance factor
+omega :: Int
+omega = 4
+
+lbalance, rbalance :: 
+  (Ord k, Ord p) => k-> p -> LTree k p -> k -> LTree k p -> LTree k p
+
+lbalance k p l m r
+  | size' l + size' r < 2     = lloser        k p l m r
+  | size' r > omega * size' l = lbalanceLeft  k p l m r
+  | size' l > omega * size' r = lbalanceRight k p l m r
+  | otherwise               = lloser        k p l m r
+
+rbalance k p l m r
+  | size' l + size' r < 2     = rloser        k p l m r
+  | size' r > omega * size' l = rbalanceLeft  k p l m r
+  | size' l > omega * size' r = rbalanceRight k p l m r
+  | otherwise               = rloser        k p l m r
+
+lbalanceLeft  k p l m r
+  | size' (left r) < size' (right r) = lsingleLeft  k p l m r
+  | otherwise                      = ldoubleLeft  k p l m r
+
+lbalanceRight k p l m r
+  | size' (left l) > size' (right l) = lsingleRight k p l m r
+  | otherwise                      = ldoubleRight k p l m r
+
+
+rbalanceLeft  k p l m r
+  | size' (left r) < size' (right r) = rsingleLeft  k p l m r
+  | otherwise                      = rdoubleLeft  k p l m r
+
+rbalanceRight k p l m r
+  | size' (left l) > size' (right l) = rsingleRight k p l m r
+  | otherwise                      = rdoubleRight k p l m r
+
+
+
+
+lsingleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3)
+  | p1 <= p2  = lloser k1 p1 (rloser k2 p2 t1 m1 t2) m2 t3
+  | otherwise = lloser k2 p2 (lloser k1 p1 t1 m1 t2) m2 t3
+
+lsingleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) =  
+  rloser k2 p2 (lloser k1 p1 t1 m1 t2) m2 t3
+
+rsingleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3) =  
+  rloser k1 p1 (rloser k2 p2 t1 m1 t2) m2 t3
+
+rsingleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) =  
+  rloser k2 p2 (rloser k1 p1 t1 m1 t2) m2 t3
+
+lsingleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 =  
+  lloser k2 p2 t1 m1 (lloser k1 p1 t2 m2 t3)
+
+lsingleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3 =  
+  lloser k1 p1 t1 m1 (lloser k2 p2 t2 m2 t3)
+
+rsingleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 =  
+  lloser k2 p2 t1 m1 (rloser k1 p1 t2 m2 t3)
+
+rsingleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3
+  | p1 <= p2  = rloser k1 p1 t1 m1 (lloser k2 p2 t2 m2 t3)
+  | otherwise = rloser k2 p2 t1 m1 (rloser k1 p1 t2 m2 t3)
+
+
+
+ldoubleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3) = 
+  lsingleLeft k1 p1 t1 m1 (lsingleRight k2 p2 t2 m2 t3)
+
+ldoubleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) =  
+  lsingleLeft k1 p1 t1 m1 (rsingleRight k2 p2 t2 m2 t3)
+
+ldoubleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 =  
+  lsingleRight k1 p1 (lsingleLeft k2 p2 t1 m1 t2) m2 t3
+
+ldoubleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3 =  
+  lsingleRight k1 p1 (rsingleLeft k2 p2 t1 m1 t2) m2 t3
+
+rdoubleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3) = 
+  rsingleLeft k1 p1 t1 m1 (lsingleRight k2 p2 t2 m2 t3)
+
+rdoubleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) =  
+  rsingleLeft k1 p1 t1 m1 (rsingleRight k2 p2 t2 m2 t3)
+
+rdoubleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 =  
+  rsingleRight k1 p1 (lsingleLeft k2 p2 t1 m1 t2) m2 t3
+
+rdoubleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3 =  
+  rsingleRight k1 p1 (rsingleLeft k2 p2 t1 m1 t2) m2 t3
+
+
+play :: (Ord k, Ord p) => PSQ k p -> PSQ k p -> PSQ k p
+
+Void `play` t' = t'
+t `play` Void  = t
+
+Winner k p t m  `play`  Winner k' p' t' m'
+  | p <= p'   = Winner k  p  (rbalance k' p' t m t') m'
+  | otherwise = Winner k' p' (lbalance k  p  t m t') m'
+
+unsafePlay :: (Ord k, Ord p) => PSQ k p -> PSQ k p -> PSQ k p
+
+Void `unsafePlay` t' =  t'
+t `unsafePlay` Void  =  t
+
+Winner k p t m  `unsafePlay`  Winner k' p' t' m'
+  | p <= p'   = Winner k  p  (rbalance k' p' t m t') m'
+  | otherwise = Winner k' p' (lbalance k  p  t m t') m'
+
+
+
+data TourView k p = Null | Single k p | PSQ k p `Play` PSQ k p
+
+tourView :: (Ord k) => PSQ k p -> TourView k p
+
+tourView Void                  =  Null
+tourView (Winner k p Start _m) =  Single k p
+
+tourView (Winner k p (RLoser _ k' p' tl m tr) m') =  
+  Winner k  p  tl m `Play` Winner k' p' tr m'
+
+tourView (Winner k p (LLoser _ k' p' tl m tr) m') =  
+  Winner k' p' tl m `Play` Winner k  p  tr m'
+
+
+
+
+
+
+--------------------------------------
+-- Hughes's efficient sequence type --
+--------------------------------------
+
+singleSequ :: a -> Sequ a
+seqFromList   :: [a] -> Sequ a
+seqFromListT  :: ([a] -> [a]) -> Sequ a
+seqToList     :: Sequ a -> [a] 
+
+newtype Sequ a  =  Sequ ([a] -> [a])
+
+singleSequ a       = Sequ (\as -> a : as)
+seqFromList as     = Sequ (\as' -> as ++ as')
+seqFromListT as    = Sequ as
+seqToList (Sequ x) = x []
+
+instance Show a => Show (Sequ a) where
+    showsPrec d a = showsPrec d (seqToList a)
+
+instance Semigroup (Sequ a) where
+    Sequ x1 <> Sequ x2 = Sequ (\as -> x1 (x2 as))
+
+instance Monoid (Sequ a) where
+    mempty = Sequ (\as -> as)
+
+guard :: Bool -> Sequ a -> Sequ a
+guard False _as = mempty
+guard True  as  = as
+
+
+
+
+---------------------------------
+------------ Tests --------------
+---------------------------------
+
+{-
+
+isBalanced Start = True
+isBalanced (LLoser s k p l m r) =
+  (size' l + size' r <= 2 ||(size' l<=omega*size' r && size' r<=omega*size' l))
+  && isBalanced l && isBalanced r
+isBalanced (RLoser s k p l m r) =
+  (size' l + size' r <= 2 ||(size' l<=omega*size' r && size' r<=omega*size' l))
+  && isBalanced l && isBalanced r
+
+instance (Ord k, Ord p, Arbitrary k, Arbitrary p) => Arbitrary (PSQ k p)
+  where 
+    coarbitrary = undefined
+    arbitrary = 
+      do ks <- arbitrary
+         ps <- arbitrary
+         return . fromList $ zipWith (:->) ks ps
+
+prop_Balanced :: PSQ Int Int -> Bool
+prop_Balanced Void = True
+prop_Balanced (Winner _ _ t _) = isBalanced t
+
+prop_OrderedKeys :: PSQ Int Int -> Bool
+prop_OrderedKeys t = let ks = map key . toAscList $ t in sort ks == ks
+
+prop_AtMost :: (PSQ Int Int,Int) -> Bool
+prop_AtMost (t,p) = 
+  let ps = map prio . atMost p $ t 
+  in all (<=p) ps
+
+prop_AtMostRange :: (PSQ Int Int,Int,Int,Int) -> Bool
+prop_AtMostRange (t,p,l_,r_) = 
+  let l = min (abs l_) (abs r_)
+      r = max (abs l_) (abs r_)
+      (ks,ps) = unzip . map (\b -> (key b,prio b)) . atMostRange p (l,r) $ t 
+  in  all (flip inrange (l,r)) ks && all (<=p) ps
+
+prop_MinView :: PSQ Int Int -> Bool
+prop_MinView t = 
+  case minView t of 
+    Nothing -> True
+    Just (b1,t') ->
+      case minView t' of
+        Nothing -> True
+        Just (b2,_) -> prio b1 <= prio b2 && prop_MinView t'
+
+tests =
+  do
+  putStrLn "Balanced"
+  quickCheck prop_Balanced
+  putStrLn "OrderedKeys"
+  quickCheck prop_OrderedKeys
+  putStrLn "MinView"
+  quickCheck prop_MinView
+  putStrLn "AtMost"
+  quickCheck prop_AtMost
+  putStrLn "AtMostRange"
+  quickCheck prop_AtMostRange
+-}