-- |
-- Module      : MonusWeightedSearch.Internal.AdjList
-- Copyright   : (c) Donnacha Oisín Kidney 2021
-- Maintainer  : mail@doisinkidney.com
-- Stability   : experimental
-- Portability : non-portable
--
-- This module provides an implementation of weighted graphs as arrays of words.
-- It's useful for generating random graphs, and performance testing.

module MonusWeightedSearch.Internal.AdjList
  ( AdjList(..)
  , randAdjList
  , alSize
  , toGraph
  , fromGraph
  ) where

import Data.Monus.Dist
import Data.Array.Unboxed
import Control.DeepSeq
import Test.QuickCheck
import Data.List
import MonusWeightedSearch.Internal.CoerceOperators
import MonusWeightedSearch.Internal.TestHelpers
import System.Random
import Data.Bool

-- | A graph with vertices labelled by words, and edges weighted by words.
newtype AdjList
  = AdjList
  { AdjList -> UArray (Word, Word) Word
edges :: UArray (Word,Word) Word
  } deriving (AdjList -> AdjList -> Bool
(AdjList -> AdjList -> Bool)
-> (AdjList -> AdjList -> Bool) -> Eq AdjList
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AdjList -> AdjList -> Bool
$c/= :: AdjList -> AdjList -> Bool
== :: AdjList -> AdjList -> Bool
$c== :: AdjList -> AdjList -> Bool
Eq, Eq AdjList
Eq AdjList
-> (AdjList -> AdjList -> Ordering)
-> (AdjList -> AdjList -> Bool)
-> (AdjList -> AdjList -> Bool)
-> (AdjList -> AdjList -> Bool)
-> (AdjList -> AdjList -> Bool)
-> (AdjList -> AdjList -> AdjList)
-> (AdjList -> AdjList -> AdjList)
-> Ord AdjList
AdjList -> AdjList -> Bool
AdjList -> AdjList -> Ordering
AdjList -> AdjList -> AdjList
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AdjList -> AdjList -> AdjList
$cmin :: AdjList -> AdjList -> AdjList
max :: AdjList -> AdjList -> AdjList
$cmax :: AdjList -> AdjList -> AdjList
>= :: AdjList -> AdjList -> Bool
$c>= :: AdjList -> AdjList -> Bool
> :: AdjList -> AdjList -> Bool
$c> :: AdjList -> AdjList -> Bool
<= :: AdjList -> AdjList -> Bool
$c<= :: AdjList -> AdjList -> Bool
< :: AdjList -> AdjList -> Bool
$c< :: AdjList -> AdjList -> Bool
compare :: AdjList -> AdjList -> Ordering
$ccompare :: AdjList -> AdjList -> Ordering
Ord)

instance NFData AdjList where
  rnf :: AdjList -> ()
rnf = (UArray (Word, Word) Word -> () -> ())
-> () -> UArray (Word, Word) Word -> ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip UArray (Word, Word) Word -> () -> ()
seq () (UArray (Word, Word) Word -> ())
-> (AdjList -> UArray (Word, Word) Word) -> AdjList -> ()
forall a b c. Coercible a b => (b -> c) -> (a -> b) -> a -> c
.# AdjList -> UArray (Word, Word) Word
edges
  {-# INLINE rnf #-}

edgeDensity :: Word
-- ^The default edge density of randomly-generated graphs.
edgeDensity :: Word
edgeDensity = Word
50

-- | Generate a random graph.
randAdjList :: Word -- ^ Edge Density (as a percentage)
            -> Word -- ^ Size
            -> IO AdjList
randAdjList :: Word -> Word -> IO AdjList
randAdjList Word
edgeDensity Word
n =
      UArray (Word, Word) Word -> AdjList
AdjList (UArray (Word, Word) Word -> AdjList)
-> ([((Word, Word), Word)] -> UArray (Word, Word) Word)
-> [((Word, Word), Word)]
-> AdjList
forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. ((Word, Word), (Word, Word))
-> [((Word, Word), Word)] -> UArray (Word, Word) Word
forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array ((Word
0,Word
0),(Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
-Word
1,Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
-Word
1))
         ([((Word, Word), Word)] -> AdjList)
-> IO [((Word, Word), Word)] -> IO AdjList
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO ((Word, Word), Word)] -> IO [((Word, Word), Word)]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ ((Word, Word), IO Word) -> IO ((Word, Word), Word)
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ((Word
i,Word
j), IO Word
edge)
                      | Word
i <- [Word
0..Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
-Word
1], Word
j <- [Word
0..Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
-Word
1], Word
i Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
/= Word
j ]
  where
    edge :: IO Word
    edge :: IO Word
edge = Word -> IO Bool
percentageChanceIO Word
edgeDensity IO Bool -> (Bool -> IO Word) -> IO Word
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Word -> IO Word -> Bool -> IO Word
forall a. a -> a -> Bool -> a
bool (Word -> IO Word
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Word
0) ((Word, Word) -> IO Word
forall a (m :: Type -> Type).
(Random a, MonadIO m) =>
(a, a) -> m a
randomRIO (Word
1, Word
30))
    {-# INLINE edge #-}
{-# INLINE randAdjList #-}

instance Arbitrary AdjList where
  arbitrary :: Gen AdjList
arbitrary = (Int -> Gen AdjList) -> Gen AdjList
forall a. (Int -> Gen a) -> Gen a
sized (Word -> Gen AdjList
go (Word -> Gen AdjList) -> (Int -> Word) -> Int -> Gen AdjList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word
forall a. Enum a => a -> a
succ (Word -> Word) -> (Int -> Word) -> Int -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word
forall a. Enum a => Int -> a
toEnum)
    where
      go :: Word -> Gen AdjList
      go :: Word -> Gen AdjList
go Word
n = UArray (Word, Word) Word -> AdjList
AdjList (UArray (Word, Word) Word -> AdjList)
-> ([((Word, Word), Word)] -> UArray (Word, Word) Word)
-> [((Word, Word), Word)]
-> AdjList
forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
#. ((Word, Word), (Word, Word))
-> [((Word, Word), Word)] -> UArray (Word, Word) Word
forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array ((Word
0,Word
0),(Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
-Word
1,Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
-Word
1))
         ([((Word, Word), Word)] -> AdjList)
-> Gen [((Word, Word), Word)] -> Gen AdjList
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen ((Word, Word), Word)] -> Gen [((Word, Word), Word)]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ ((Word, Word), Gen Word) -> Gen ((Word, Word), Word)
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ((Word
i,Word
j), Word -> Gen Bool
percentageChance Word
edgeDensity Gen Bool -> (Bool -> Gen Word) -> Gen Word
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Gen Word -> Gen Word -> Bool -> Gen Word
forall a. a -> a -> Bool -> a
bool (Word -> Gen Word
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Word
0) ((Word -> Word) -> Gen Word -> Gen Word
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Word -> Word
forall a. Enum a => a -> a
succ Gen Word
forall a. Arbitrary a => Gen a
arbitrary))
                      | Word
i <- [Word
0..Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
-Word
1], Word
j <- [Word
0..Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
-Word
1], Word
i Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
/= Word
j ]
  shrink :: AdjList -> [AdjList]
shrink AdjList
xs = Int -> [AdjList] -> [AdjList]
forall a. Int -> [a] -> [a]
take (Word -> Int
forall a. Enum a => a -> Int
fromEnum (AdjList -> Word
alSize AdjList
xs) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ((AdjList -> AdjList) -> AdjList -> [AdjList]
forall a. (a -> a) -> a -> [a]
iterate AdjList -> AdjList
cut (AdjList -> AdjList
cut AdjList
xs))
    where
      cut :: AdjList -> AdjList
cut AdjList
ar = UArray (Word, Word) Word -> AdjList
AdjList (((Word, Word), (Word, Word)) -> [Word] -> UArray (Word, Word) Word
forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray ((Word
0,Word
0),(Word
s,Word
s)) (((Word, Word) -> Word) -> [(Word, Word)] -> [Word]
forall a b. (a -> b) -> [a] -> [b]
map (AdjList -> UArray (Word, Word) Word
edges AdjList
ar UArray (Word, Word) Word -> (Word, Word) -> Word
forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!) (((Word, Word), (Word, Word)) -> [(Word, Word)]
forall a. Ix a => (a, a) -> [a]
range ((Word
0,Word
0),(Word
s,Word
s)))))
        where s :: Word
s = AdjList -> Word
alSize AdjList
ar Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
2

-- | Return the number of vertices in the graph.
alSize :: AdjList -> Word
alSize :: AdjList -> Word
alSize = Word -> Word
forall a. Enum a => a -> a
succ (Word -> Word) -> (AdjList -> Word) -> AdjList -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word, Word) -> Word
forall a b. (a, b) -> b
snd ((Word, Word) -> Word)
-> (AdjList -> (Word, Word)) -> AdjList -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word, Word), (Word, Word)) -> (Word, Word)
forall a b. (a, b) -> b
snd (((Word, Word), (Word, Word)) -> (Word, Word))
-> (AdjList -> ((Word, Word), (Word, Word)))
-> AdjList
-> (Word, Word)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UArray (Word, Word) Word -> ((Word, Word), (Word, Word))
forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds (UArray (Word, Word) Word -> ((Word, Word), (Word, Word)))
-> (AdjList -> UArray (Word, Word) Word)
-> AdjList
-> ((Word, Word), (Word, Word))
forall a b c. Coercible a b => (b -> c) -> (a -> b) -> a -> c
.# AdjList -> UArray (Word, Word) Word
edges)
{-# INLINE alSize #-}

-- | Convert an adjacency list to a standard graph.
toGraph :: AdjList -> Graph Word
toGraph :: AdjList -> Graph Word
toGraph (AdjList UArray (Word, Word) Word
xs) Word
i
  | Word
i Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= (Word, Word) -> Word
forall a b. (a, b) -> b
snd (((Word, Word), (Word, Word)) -> (Word, Word)
forall a b. (a, b) -> b
snd (UArray (Word, Word) Word -> ((Word, Word), (Word, Word))
forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray (Word, Word) Word
xs)) =
    [ (Word
j,Int -> Dist
forall a. Enum a => Int -> a
toEnum (Word -> Int
forall a. Enum a => a -> Int
fromEnum Word
d))
    | Word
j <- [Word
0..(Word, Word) -> Word
forall a b. (a, b) -> b
snd (((Word, Word), (Word, Word)) -> (Word, Word)
forall a b. (a, b) -> b
snd (UArray (Word, Word) Word -> ((Word, Word), (Word, Word))
forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray (Word, Word) Word
xs))], let d :: Word
d = UArray (Word, Word) Word
xs UArray (Word, Word) Word -> (Word, Word) -> Word
forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! (Word
i,Word
j), Word
d Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
/= Word
0 ]
  | Bool
otherwise = []
{-# INLINE toGraph #-}

-- | Convert a graph to an adjacency list.
fromGraph :: Word -- ^ The number of vertices in the graph.
  -> Graph Word -- ^ The graph.
  -> AdjList
fromGraph :: Word -> Graph Word -> AdjList
fromGraph Word
n Graph Word
g =
  UArray (Word, Word) Word -> AdjList
AdjList (((Word, Word), (Word, Word))
-> [((Word, Word), Word)] -> UArray (Word, Word) Word
forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array ((Word
0,Word
0),(Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
-Word
1,Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
-Word
1)) [ ((Word
i,Word
j),Int -> Word
forall a. Enum a => Int -> a
toEnum (Dist -> Int
forall a. Enum a => a -> Int
fromEnum Dist
d)) | Word
i <- [Word
0..Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
-Word
1], (Word
j,Dist
d) <- Graph Word
g Word
i ])
{-# INLINE fromGraph #-}

instance Show AdjList where
  show :: AdjList -> String
show AdjList
al = [String] -> String
unlines (String
top String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"│             │" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [[String]] -> [String]
forall a. [a] -> [[a]] -> [a]
intercalate [String
sep] [ Word -> [(Word, Dist)] -> [String]
forall {a} {a} {a}.
(Show a, Show a, Show a) =>
a -> [(a, a)] -> [String]
go Word
s (AdjList -> Graph Word
toGraph AdjList
al Word
s)  | Word
s <- [Word
0..AdjList -> Word
alSize AdjList
al Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
1] ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
bot])
    where
      top :: String
top = Char
'┌' Char -> ShowS
forall a. a -> [a] -> [a]
: (Word, Word) -> ShowS
forall {a}. Show a => a -> ShowS
showPad (Word
0 :: Word,AdjList -> Word
alSize AdjList
al Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
1) String
" ────────────┐"
      bot :: String
bot = String
"└─────────────┘"
      sep :: String
sep = String
"├╌╌╌╌╌╌╌╌╌╌╌╌╌┤"

      go :: a -> [(a, a)] -> [String]
go a
s []     = [String
"│ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> ShowS
forall {a}. Show a => a -> ShowS
showPad a
s String
" ──────> [] │"]
      go a
s ((a
x,a
xw):[(a, a)]
xs) = (String
"│ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> ShowS
forall {a}. Show a => a -> ShowS
showPad a
s (String
" ──" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> a -> String
forall {a}. Show a => Int -> Char -> a -> String
showPadR Int
3 Char
'─' a
xw String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"─> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> ShowS
forall {a}. Show a => a -> ShowS
showPad a
x String
"   │")) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [(a, a)] -> [String]
forall {a} {a}. (Show a, Show a) => [(a, a)] -> [String]
go' [(a, a)]
xs

      go' :: [(a, a)] -> [String]
go' [] = []
      go' [(a
x,a
xw)] = [String
"│ └──" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> a -> String
forall {a}. Show a => Int -> Char -> a -> String
showPadR Int
3 Char
'─' a
xw String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"─> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> ShowS
forall {a}. Show a => a -> ShowS
showPad a
x String
"   │"]
      go' ((a
x,a
xw):[(a, a)]
xs) = (String
"│ ├──" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> a -> String
forall {a}. Show a => Int -> Char -> a -> String
showPadR Int
3 Char
'─' a
xw String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"─> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> ShowS
forall {a}. Show a => a -> ShowS
showPad a
x String
"   │") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [(a, a)] -> [String]
go' [(a, a)]
xs

      tail' :: [a] -> [a]
tail' [] = []
      tail' (a
_:[a]
xs) = [a]
xs

      showPad :: a -> ShowS
showPad a
v = (Char -> ShowS -> ShowS) -> ShowS -> String -> ShowS
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ShowS -> ShowS
forall {a} {a}. a -> ([a] -> [a]) -> [a] -> [a]
f ShowS
forall a. a -> a
id (a -> String
forall a. Show a => a -> String
show a
v)
        where
          f :: a -> ([a] -> [a]) -> [a] -> [a]
f a
x [a] -> [a]
k [a]
ys = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
k ([a] -> [a]
forall {a}. [a] -> [a]
tail' [a]
ys)

      showPadR :: Int -> Char -> a -> String
showPadR Int
n Char
c a
v = let x :: String
x = a -> String
forall a. Show a => a -> String
show a
v in Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length String
x) Char
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x