msakai / toysolver / 496

Committed 10 Nov 2024 11:05AM UTC coverage: 69.994% (-1.1%) from 71.113%

Build # 496

Build Type

push

github

Committed by

web-flow

Commit Message

Merge pull request #117 from msakai/update-coveralls-and-haddock

GitHub Actions: Update coveralls and haddock configuration

Run Details

9872 of 14104 relevant lines covered (69.99%)

0.7 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

81.67

/src/ToySolver/Internal/Data/IndexedPriorityQueue.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
#ifdef __GLASGOW_HASKELL__
#define UNBOXED_COMPARISON_ARGUMENTS
#endif
#ifdef UNBOXED_COMPARISON_ARGUMENTS
{-# LANGUAGE MagicHash #-}
#endif
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Internal.Data.IndexedPriorityQueue
-- Copyright   :  (c) Masahiro Sakai 2012
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-- Priority queue implemented as array-based binary heap.
--
-----------------------------------------------------------------------------
module ToySolver.Internal.Data.IndexedPriorityQueue
  (
  -- * PriorityQueue type
    PriorityQueue
  , Value
  , Index

  -- * Constructors
  , newPriorityQueue
  , newPriorityQueueBy
  , NewFifo (..)

  -- * Operators
  , getElems
  , clear
  , clone
  , Enqueue (..)
  , Dequeue (..)
  , QueueSize (..)
  , member
  , update
  , rebuild
  , getHeapArray
  , getHeapVec

  -- * Misc operations
  , resizeHeapCapacity
  , resizeTableCapacity
  ) where

import Control.Loop
import Control.Monad
import qualified Data.Array.IO as A
import Data.Queue.Classes
import qualified ToySolver.Internal.Data.Vec as Vec
#ifdef UNBOXED_COMPARISON_ARGUMENTS
import GHC.Exts
#endif

type Index = Int
type Value = Int

-- | Priority queue implemented as array-based binary heap.
data PriorityQueue
  = PriorityQueue
#ifdef UNBOXED_COMPARISON_ARGUMENTS
  { lt#  :: !(Int# -> Int# -> IO Bool)
#else
  { lt   :: !(Value -> Value -> IO Bool)
#endif
  , heap :: !(Vec.UVec Value)
  , table  :: !(Vec.UVec Index)
  }

-- | Build a priority queue with default ordering ('(<)' of 'Ord' class)
newPriorityQueue :: IO PriorityQueue
newPriorityQueue = newPriorityQueueBy (\a b -> return (a < b))

#ifdef UNBOXED_COMPARISON_ARGUMENTS

{-# INLINE newPriorityQueueBy #-}
-- | Build a priority queue with a given /less than/ operator.
newPriorityQueueBy :: (Value -> Value -> IO Bool) -> IO PriorityQueue
newPriorityQueueBy cmp = newPriorityQueueBy# cmp#
  where
    cmp# a b = cmp (I# a) (I# b)

-- | Build a priority queue with a given /less than/ operator.
newPriorityQueueBy# :: (Int# -> Int# -> IO Bool) -> IO PriorityQueue
newPriorityQueueBy# cmp# = do
  vec <- Vec.new
  idx <- Vec.new
  return $ PriorityQueue{ lt# = cmp#, heap = vec, table = idx }

{-# INLINE lt #-}
lt :: PriorityQueue -> Value -> Value -> IO Bool
lt q (I# a) (I# b) = lt# q a b

#else

-- | Build a priority queue with a given /less than/ operator.
newPriorityQueueBy :: (Value -> Value -> IO Bool) -> IO PriorityQueue
newPriorityQueueBy cmp = do
  vec <- Vec.new
  idx <- Vec.new
  return $ PriorityQueue{ lt = cmp, heap = vec, table = idx }

#endif

-- | Return a list of all the elements of a priority queue. (not sorted)
getElems :: PriorityQueue -> IO [Value]
getElems q = Vec.getElems (heap q)

-- | Remove all elements from a priority queue.
clear :: PriorityQueue -> IO ()
clear q = do
  Vec.clear (heap q)
  Vec.clear (table q)

-- | Create a copy of a priority queue.
clone :: PriorityQueue -> IO PriorityQueue
clone q = do
  h2 <- Vec.clone (heap q)
  t2 <- Vec.clone (table q)
  return $ q{ heap = h2, table = t2 }

instance NewFifo PriorityQueue IO where
  newFifo = newPriorityQueue

instance Enqueue PriorityQueue IO Value where
  enqueue q val = do
    m <- member q val
    unless m $ do
      n <- Vec.getSize (heap q)
      Vec.push (heap q) val
      Vec.growTo (table q) (val+1)
      Vec.unsafeWrite (table q) val n
      up q n

instance Dequeue PriorityQueue IO Value where
  dequeue q = do
    n <- Vec.getSize (heap q)
    case n of
      0 ->
        return Nothing
      _ -> do
        val <- Vec.unsafeRead (heap q) 0
        Vec.unsafeWrite (table q) val (-1)
        if n == 1 then do
          Vec.resize (heap q) (n-1)
        else do
          val1 <- Vec.unsafePop (heap q)
          Vec.unsafeWrite (heap q) 0 val1
          Vec.unsafeWrite (table q) val1 0
          down q 0
        return (Just val)

  dequeueBatch q = go []
    where
      go :: [Value] -> IO [Value]
      go xs = do
        r <- dequeue q
        case r of
          Nothing -> return (reverse xs)
          Just x -> go (x:xs)

instance QueueSize PriorityQueue IO where
  queueSize q = Vec.getSize (heap q)

member :: PriorityQueue -> Value -> IO Bool
member q v = do
  n <- Vec.getSize (table q)
  if n <= v then
    return False
  else do
    i <- Vec.unsafeRead (table q) v
    return $! i /= -1

update :: PriorityQueue -> Value -> IO ()
update q v = do
  i <- Vec.unsafeRead (table q) v
  unless (i == -1) $ do
    up q i
    down q i

up :: PriorityQueue -> Index -> IO ()
up q !i = do
  val <- Vec.unsafeRead (heap q) i
  let loop 0 = return 0
      loop j = do
        let p = parent j
        val_p <- Vec.unsafeRead (heap q) p
        b <- lt q val val_p
        if b
          then do
            Vec.unsafeWrite (heap q) j val_p
            Vec.unsafeWrite (table q) val_p j
            loop p
          else return j
  j <- loop i
  Vec.unsafeWrite (heap q) j val
  Vec.unsafeWrite (table q) val j

down :: PriorityQueue -> Index -> IO ()
down q !i = do
  n <- Vec.getSize (heap q)
  val <- Vec.unsafeRead (heap q) i
  let loop !j = do
        let !l = left j
            !r = right j
        if l >= n
         then return j
         else do
           child <- do
             if r >= n
              then return l
              else do
                val_l <- Vec.unsafeRead (heap q) l
                val_r <- Vec.unsafeRead (heap q) r
                b <- lt q val_r val_l
                if b
                  then return r
                  else return l
           val_child <- Vec.unsafeRead (heap q) child
           b <- lt q val_child val
           if not b
             then return j
             else do
               Vec.unsafeWrite (heap q) j val_child
               Vec.unsafeWrite (table q) val_child j
               loop child
  j <- loop i
  Vec.unsafeWrite (heap q) j val
  Vec.unsafeWrite (table q) val j

rebuild :: PriorityQueue -> IO ()
rebuild q = do
  n <- Vec.getSize (heap q)
  forLoop 0 (<n) (+1) $ \i -> do
    up q i

-- | Get the internal representation of a given priority queue.
getHeapArray :: PriorityQueue -> IO (A.IOUArray Index Value)
getHeapArray q = Vec.getArray (heap q)

-- | Get the internal representation of a given priority queue.
getHeapVec :: PriorityQueue -> IO (Vec.UVec Value)
getHeapVec q = return (heap q)

-- | Pre-allocate internal buffer for @n@ elements.
resizeHeapCapacity :: PriorityQueue -> Int -> IO ()
resizeHeapCapacity q capa = Vec.resizeCapacity (heap q) capa

-- | Pre-allocate internal buffer for @[0..n-1]@ values.
resizeTableCapacity :: PriorityQueue -> Int -> IO ()
resizeTableCapacity q capa = Vec.resizeCapacity (table q) capa

{--------------------------------------------------------------------
  Index "traversal" functions
--------------------------------------------------------------------}

{-# INLINE left #-}
left :: Index -> Index
left i = i*2 + 1

{-# INLINE right #-}
right :: Index -> Index
right i = (i+1)*2;

{-# INLINE parent #-}
parent :: Index -> Index
parent i = (i-1) `div` 2

{--------------------------------------------------------------------
  test
--------------------------------------------------------------------}

{-
checkHeapProperty :: String -> PriorityQueue -> IO ()
checkHeapProperty str q = do
  (n,arr) <- readIORef (heap q)
  let go i = do
        val <- A.readArray arr i
        forM_ [left i, right i] $ \j ->
          when (j < n) $ do
            val2 <- A.readArray arr j
            b <- lt q val2 val
            when b $ do
              error (str ++ ": invalid heap " ++ show j)
            go j
  when (n > 0) $ go 0

  idx <- readIORef (table q)
  forM_ [0..n-1] $ \i -> do
    v <- A.readArray arr i
    i' <- A.readArray idx v
    when (i /= i') $ error $ str ++ ": invalid index " ++ show (i,v,i')
-}

1	{-# LANGUAGE BangPatterns #-}
2	{-# LANGUAGE CPP #-}
3	{-# LANGUAGE FlexibleInstances #-}
4	{-# LANGUAGE MultiParamTypeClasses #-}
5	{-# LANGUAGE TypeSynonymInstances #-}
6	#ifdef __GLASGOW_HASKELL__
7	#define UNBOXED_COMPARISON_ARGUMENTS
8	#endif
9	#ifdef UNBOXED_COMPARISON_ARGUMENTS
10	{-# LANGUAGE MagicHash #-}
11	#endif
12	{-# OPTIONS_GHC -Wall #-}
13	{-# OPTIONS_HADDOCK show-extensions #-}
14	-----------------------------------------------------------------------------
15	-- \|
16	-- Module : ToySolver.Internal.Data.IndexedPriorityQueue
17	-- Copyright : (c) Masahiro Sakai 2012
18	-- License : BSD-style
19	--
20	-- Maintainer : masahiro.sakai@gmail.com
21	-- Stability : provisional
22	-- Portability : non-portable
23	--
24	-- Priority queue implemented as array-based binary heap.
25	--
26	-----------------------------------------------------------------------------
27	module ToySolver.Internal.Data.IndexedPriorityQueue
28	(
29	-- * PriorityQueue type
30	PriorityQueue
31	, Value
32	, Index
33
34	-- * Constructors
35	, newPriorityQueue
36	, newPriorityQueueBy
37	, NewFifo (..)
38
39	-- * Operators
40	, getElems
41	, clear
42	, clone
43	, Enqueue (..)
44	, Dequeue (..)
45	, QueueSize (..)
46	, member
47	, update
48	, rebuild
49	, getHeapArray
50	, getHeapVec
51
52	-- * Misc operations
53	, resizeHeapCapacity
54	, resizeTableCapacity
55	) where
56
57	import Control.Loop
58	import Control.Monad
59	import qualified Data.Array.IO as A
60	import Data.Queue.Classes
61	import qualified ToySolver.Internal.Data.Vec as Vec
62	#ifdef UNBOXED_COMPARISON_ARGUMENTS
63	import GHC.Exts
64	#endif
65
66	type Index = Int
67	type Value = Int
68
69	-- \| Priority queue implemented as array-based binary heap.
70	data PriorityQueue
71	= PriorityQueue
72	#ifdef UNBOXED_COMPARISON_ARGUMENTS
73	{ lt# :: !(Int# -> Int# -> IO Bool)	1✔
74	#else
75	{ lt :: !(Value -> Value -> IO Bool)
76	#endif
77	, heap :: !(Vec.UVec Value)	1✔
78	, table :: !(Vec.UVec Index)	1✔
79	}
80
81	-- \| Build a priority queue with default ordering ('(<)' of 'Ord' class)
82	newPriorityQueue :: IO PriorityQueue
83	newPriorityQueue = newPriorityQueueBy (\a b -> return (a < b))	×
84
85	#ifdef UNBOXED_COMPARISON_ARGUMENTS
86
87	{-# INLINE newPriorityQueueBy #-}
88	-- \| Build a priority queue with a given /less than/ operator.
89	newPriorityQueueBy :: (Value -> Value -> IO Bool) -> IO PriorityQueue
90	newPriorityQueueBy cmp = newPriorityQueueBy# cmp#	1✔
91	where
92	cmp# a b = cmp (I# a) (I# b)	1✔
93
94	-- \| Build a priority queue with a given /less than/ operator.
95	newPriorityQueueBy# :: (Int# -> Int# -> IO Bool) -> IO PriorityQueue
96	newPriorityQueueBy# cmp# = do	1✔
97	vec <- Vec.new	1✔
98	idx <- Vec.new	1✔
99	return $ PriorityQueue{ lt# = cmp#, heap = vec, table = idx }	1✔
100
101	{-# INLINE lt #-}
102	lt :: PriorityQueue -> Value -> Value -> IO Bool
103	lt q (I# a) (I# b) = lt# q a b	1✔
104
105	#else
106
107	-- \| Build a priority queue with a given /less than/ operator.
108	newPriorityQueueBy :: (Value -> Value -> IO Bool) -> IO PriorityQueue
109	newPriorityQueueBy cmp = do
110	vec <- Vec.new
111	idx <- Vec.new
112	return $ PriorityQueue{ lt = cmp, heap = vec, table = idx }
113
114	#endif
115
116	-- \| Return a list of all the elements of a priority queue. (not sorted)
117	getElems :: PriorityQueue -> IO [Value]
118	getElems q = Vec.getElems (heap q)	×
119
120	-- \| Remove all elements from a priority queue.
121	clear :: PriorityQueue -> IO ()
122	clear q = do	×
123	Vec.clear (heap q)	×
124	Vec.clear (table q)	×
125
126	-- \| Create a copy of a priority queue.
127	clone :: PriorityQueue -> IO PriorityQueue
128	clone q = do	×
129	h2 <- Vec.clone (heap q)	×
130	t2 <- Vec.clone (table q)	×
131	return $ q{ heap = h2, table = t2 }	×
132
133	instance NewFifo PriorityQueue IO where
134	newFifo = newPriorityQueue	×
135
136	instance Enqueue PriorityQueue IO Value where	×
137	enqueue q val = do	1✔
138	m <- member q val	1✔
139	unless m $ do	1✔
140	n <- Vec.getSize (heap q)	1✔
141	Vec.push (heap q) val	1✔
142	Vec.growTo (table q) (val+1)	1✔
143	Vec.unsafeWrite (table q) val n	1✔
144	up q n	1✔
145
146	instance Dequeue PriorityQueue IO Value where
147	dequeue q = do	1✔
148	n <- Vec.getSize (heap q)	1✔
149	case n of	1✔
150	0 ->
151	return Nothing	1✔
152	_ -> do	1✔
153	val <- Vec.unsafeRead (heap q) 0	1✔
154	Vec.unsafeWrite (table q) val (-1)	1✔
155	if n == 1 then do	1✔
156	Vec.resize (heap q) (n-1)	1✔
157	else do	1✔
158	val1 <- Vec.unsafePop (heap q)	1✔
159	Vec.unsafeWrite (heap q) 0 val1	1✔
160	Vec.unsafeWrite (table q) val1 0	1✔
161	down q 0	1✔
162	return (Just val)	1✔
163
164	dequeueBatch q = go []	×
165	where
166	go :: [Value] -> IO [Value]
167	go xs = do	×
168	r <- dequeue q	×
169	case r of	×
170	Nothing -> return (reverse xs)	×
171	Just x -> go (x:xs)	×
172
173	instance QueueSize PriorityQueue IO where
174	queueSize q = Vec.getSize (heap q)	1✔
175
176	member :: PriorityQueue -> Value -> IO Bool
177	member q v = do	1✔
178	n <- Vec.getSize (table q)	1✔
179	if n <= v then	1✔
180	return False	1✔
181	else do	1✔
182	i <- Vec.unsafeRead (table q) v	1✔
183	return $! i /= -1	1✔
184
185	update :: PriorityQueue -> Value -> IO ()
186	update q v = do	1✔
187	i <- Vec.unsafeRead (table q) v	1✔
188	unless (i == -1) $ do	1✔
189	up q i	1✔
190	down q i	1✔
191
192	up :: PriorityQueue -> Index -> IO ()
193	up q !i = do	1✔
194	val <- Vec.unsafeRead (heap q) i	1✔
195	let loop 0 = return 0	1✔
196	loop j = do	1✔
197	let p = parent j	1✔
198	val_p <- Vec.unsafeRead (heap q) p	1✔
199	b <- lt q val val_p	1✔
200	if b	1✔
201	then do	1✔
202	Vec.unsafeWrite (heap q) j val_p	1✔
203	Vec.unsafeWrite (table q) val_p j	1✔
204	loop p	1✔
205	else return j	1✔
206	j <- loop i	1✔
207	Vec.unsafeWrite (heap q) j val	1✔
208	Vec.unsafeWrite (table q) val j	1✔
209
210	down :: PriorityQueue -> Index -> IO ()
211	down q !i = do	1✔
212	n <- Vec.getSize (heap q)	1✔
213	val <- Vec.unsafeRead (heap q) i	1✔
214	let loop !j = do	1✔
215	let !l = left j	1✔
216	!r = right j	1✔
217	if l >= n	1✔
218	then return j	1✔
219	else do	1✔
220	child <- do	1✔
221	if r >= n	1✔
222	then return l	1✔
223	else do	1✔
224	val_l <- Vec.unsafeRead (heap q) l	1✔
225	val_r <- Vec.unsafeRead (heap q) r	1✔
226	b <- lt q val_r val_l	1✔
227	if b	1✔
228	then return r	1✔
229	else return l	1✔
230	val_child <- Vec.unsafeRead (heap q) child	1✔
231	b <- lt q val_child val	1✔
232	if not b	1✔
233	then return j	1✔
234	else do	1✔
235	Vec.unsafeWrite (heap q) j val_child	1✔
236	Vec.unsafeWrite (table q) val_child j	1✔
237	loop child	1✔
238	j <- loop i	1✔
239	Vec.unsafeWrite (heap q) j val	1✔
240	Vec.unsafeWrite (table q) val j	1✔
241
242	rebuild :: PriorityQueue -> IO ()
243	rebuild q = do	×
244	n <- Vec.getSize (heap q)	×
245	forLoop 0 (<n) (+1) $ \i -> do	×
246	up q i	×
247
248	-- \| Get the internal representation of a given priority queue.
249	getHeapArray :: PriorityQueue -> IO (A.IOUArray Index Value)
250	getHeapArray q = Vec.getArray (heap q)	1✔
251
252	-- \| Get the internal representation of a given priority queue.
253	getHeapVec :: PriorityQueue -> IO (Vec.UVec Value)
254	getHeapVec q = return (heap q)	×
255
256	-- \| Pre-allocate internal buffer for @n@ elements.
257	resizeHeapCapacity :: PriorityQueue -> Int -> IO ()
258	resizeHeapCapacity q capa = Vec.resizeCapacity (heap q) capa	1✔
259
260	-- \| Pre-allocate internal buffer for @[0..n-1]@ values.
261	resizeTableCapacity :: PriorityQueue -> Int -> IO ()
262	resizeTableCapacity q capa = Vec.resizeCapacity (table q) capa	1✔
263
264	{--------------------------------------------------------------------
265	Index "traversal" functions
266	--------------------------------------------------------------------}
267
268	{-# INLINE left #-}
269	left :: Index -> Index
270	left i = i*2 + 1	1✔
271
272	{-# INLINE right #-}
273	right :: Index -> Index
274	right i = (i+1)*2;	1✔
275
276	{-# INLINE parent #-}
277	parent :: Index -> Index
278	parent i = (i-1) `div` 2	1✔
279
280	{--------------------------------------------------------------------
281	test
282	--------------------------------------------------------------------}
283
284	{-
285	checkHeapProperty :: String -> PriorityQueue -> IO ()
286	checkHeapProperty str q = do
287	(n,arr) <- readIORef (heap q)
288	let go i = do
289	val <- A.readArray arr i
290	forM_ [left i, right i] $ \j ->
291	when (j < n) $ do
292	val2 <- A.readArray arr j
293	b <- lt q val2 val
294	when b $ do
295	error (str ++ ": invalid heap " ++ show j)
296	go j
297	when (n > 0) $ go 0
298
299	idx <- readIORef (table q)
300	forM_ [0..n-1] $ \i -> do
301	v <- A.readArray arr i
302	i' <- A.readArray idx v
303	when (i /= i') $ error $ str ++ ": invalid index " ++ show (i,v,i')
304	-}

msakai / toysolver / 496

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous