{-# LANGUAGE DeriveGeneric, DefaultSignatures, StrictData #-}

{-|
Module      : Base
Description : Some base functions, imported by almost all other modules.
-}


module Base where


import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import Data.Word ( Word64, Word8 )
import Data.Traversable (for)
import Data.List
import Data.Foldable
import Data.Maybe (mapMaybe, fromMaybe,fromJust)
import Control.Monad.Extra (firstJustM)
import qualified Numeric (showHex,readHex)
import Debug.Trace
import GHC.Generics
import qualified Data.Serialize as Cereal 
import Control.Monad.State.Strict
import Data.Ord (comparing)
import Data.Bits (shift,testBit,clearBit,(.|.), (.&.), xor, shiftL,shiftR)
import Control.DeepSeq

import Data.Serialize.Get (getSetOf)
import Data.Serialize.Put (putSetOf)
import qualified Data.Set.NonEmpty as NES

class IntGraph g where
  intgraph_post :: g -> Int -> IS.IntSet
  intgraph_V    :: g -> IS.IntSet





-- | Show the integer in hex.
showHex :: a -> String
showHex a
i = if a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then Word64 -> ShowS
forall a. Integral a => a -> ShowS
Numeric.showHex (a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i :: Word64) String
"" else a -> ShowS
forall a. Integral a => a -> ShowS
Numeric.showHex a
i String
""
-- | Show an integer list as hex-list.
showHex_list :: [a] -> String
showHex_list [a]
is = String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall {a}. Integral a => a -> String
showHex [a]
is) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
-- | Show an integer set as hex-list.
showHex_set :: IntSet -> String
showHex_set     = [Int] -> String
forall {a}. Integral a => [a] -> String
showHex_list ([Int] -> String) -> (IntSet -> [Int]) -> IntSet -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IS.toList
-- | Show an optional integer as an optional hex.
showHex_option :: Maybe a -> String
showHex_option Maybe a
Nothing = String
"Nothing"
showHex_option (Just a
v) = a -> String
forall {a}. Integral a => a -> String
showHex a
v
-- | Read an int from a string storing a hex.
readHex' :: (Eq a, Num a) => String -> a
readHex' :: forall a. (Eq a, Num a) => String -> a
readHex' = (a, String) -> a
forall a b. (a, b) -> a
fst ((a, String) -> a) -> (String -> (a, String)) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, String)] -> (a, String)
forall a. HasCallStack => [a] -> a
head ([(a, String)] -> (a, String))
-> (String -> [(a, String)]) -> String -> (a, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(a, String)]
forall a. (Eq a, Num a) => ReadS a
Numeric.readHex

show_set :: (Foldable t,Show a) => t a -> String
show_set :: forall (t :: * -> *) a. (Foldable t, Show a) => t a -> String
show_set t a
as = String
"{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> String
forall a. Show a => a -> String
show ([a] -> [String]) -> [a] -> [String]
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
as) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}" 


-- | Lookup and produce error message if key does not exists in map.
im_lookup :: String -> IntMap a -> Int -> a
im_lookup String
s IntMap a
m Int
k =
  case Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap a
m of
    Maybe a
Nothing -> String -> a
forall a. HasCallStack => String -> a
error String
s
    Just a
v  -> a
v

-- | use a default value in case of @Nothing@
orElse :: Eq a => Maybe a -> a -> a
orElse :: forall a. Eq a => Maybe a -> a -> a
orElse Maybe a
a a
b
  | Maybe a
a Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe a
forall a. Maybe a
Nothing = a
b
  | Bool
otherwise    = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust Maybe a
a

-- | try something else if first result failed
orTry :: Eq a => Maybe a -> Maybe a -> Maybe a
orTry :: forall a. Eq a => Maybe a -> Maybe a -> Maybe a
orTry Maybe a
a Maybe a
b
  | Maybe a
a Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe a
forall a. Maybe a
Nothing = Maybe a
b
  | Bool
otherwise    = Maybe a
a

orElseM :: Monad m => m (Maybe a) -> m a -> m a
orElseM :: forall (m :: * -> *) a. Monad m => m (Maybe a) -> m a -> m a
orElseM m (Maybe a)
m0 m a
m1 = do
  Maybe a
a <- m (Maybe a)
m0
  case Maybe a
a of
    Maybe a
Nothing -> m a
m1
    Just a
a  -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


orTryM :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
orTryM :: forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
orTryM m (Maybe a)
m0 m (Maybe a)
m1 = do
  Maybe a
a <- m (Maybe a)
m0
  case Maybe a
a of
    Maybe a
Nothing -> m (Maybe a)
m1
    Just a
a  -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a
    


-- | return only if Bool holds
onlyWhen :: Bool -> a -> Maybe a
onlyWhen Bool
b a
a = if Bool
b then a -> Maybe a
forall a. a -> Maybe a
Just a
a else Maybe a
forall a. Maybe a
Nothing

-- | A value exists (is not Nothing) and satisfies the predicate
existsAndSatisfies :: Maybe t -> (t -> Bool) -> Bool
existsAndSatisfies Maybe t
Nothing  t -> Bool
p = Bool
False
existsAndSatisfies (Just t
a) t -> Bool
p = t -> Bool
p t
a  

-- | Takes computations returnings @Maybes@; tries each one in order.
-- The first one to return a @Just@ wins. Returns @Nothing@ if all computations
-- return @Nothing@.
firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)
firstJustsM :: forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Foldable f) =>
f (m (Maybe a)) -> m (Maybe a)
firstJustsM = (Maybe a -> m (Maybe a) -> m (Maybe a))
-> Maybe a -> f (m (Maybe a)) -> m (Maybe a)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Maybe a -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a.
Monad m =>
Maybe a -> m (Maybe a) -> m (Maybe a)
go Maybe a
forall a. Maybe a
Nothing where
  go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)
  go :: forall (m :: * -> *) a.
Monad m =>
Maybe a -> m (Maybe a) -> m (Maybe a)
go Maybe a
Nothing         m (Maybe a)
action  = m (Maybe a)
action
  go result :: Maybe a
result@(Just a
_) m (Maybe a)
_action = Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
result

-- | create a tuple
pair :: a -> b -> (a, b)
pair a
a b
b = (a
a,b
b)

-- | Find the index of one string in another.
findString :: (Eq a) => [a] -> [a] -> Maybe Int
findString :: forall a. Eq a => [a] -> [a] -> Maybe Int
findString [a]
search [a]
str = ([a] -> Bool) -> [[a]] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ([a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
search) ([a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
str)

-- | Take until the occurrence of the string
takeUntilString :: String -> String -> String
takeUntilString :: String -> ShowS
takeUntilString String
search []   = []
takeUntilString String
search String
str = if String
search String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
str then [] else String -> Char
forall a. HasCallStack => [a] -> a
head String
str Char -> ShowS
forall a. a -> [a] -> [a]
: String -> ShowS
takeUntilString String
search (ShowS
forall a. HasCallStack => [a] -> [a]
tail String
str)


-- | Strip outer parentheses from a string, if it has them.
strip_parentheses :: ShowS
strip_parentheses String
s = if String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& String -> Char
forall a. HasCallStack => [a] -> a
head String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& String -> Char
forall a. HasCallStack => [a] -> a
last String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' then ShowS
forall a. HasCallStack => [a] -> [a]
init ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. HasCallStack => [a] -> [a]
tail String
s else String
s



partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
-- ^ Uses a function to determine which of two output lists an input element should join
partitionWith :: forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith a -> Either b c
_ [] = ([],[])
partitionWith a -> Either b c
f (a
x:[a]
xs) = case a -> Either b c
f a
x of
                         Left  b
b -> (b
bb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
bs, [c]
cs)
                         Right c
c -> ([b]
bs, c
cc -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
cs)
    where ([b]
bs,[c]
cs) = (a -> Either b c) -> [a] -> ([b], [c])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith a -> Either b c
f [a]
xs


-- | In little endian, convert a byte-list to a 64 bit word.
-- Assume the list is at most length 8.
bytes_to_word :: [Word8] -> Word64
bytes_to_word :: [Word8] -> Word64
bytes_to_word [] = Word64
0
bytes_to_word (Word8
w:[Word8]
ws) = (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w::Word64) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shift ([Word8] -> Word64
bytes_to_word [Word8]
ws) Int
8

-- | Convert first @n@ bytes of a word to an integer.
-- Assume @n<8@.
word_to_sint :: Int -> Word64 -> Int
word_to_sint :: Int -> Word64 -> Int
word_to_sint Int
si Word64
w =
  let neg :: Bool
neg = Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
w (Int
siInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      val :: Int
val = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word64) -> Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
clearBit Word64
w (Int
siInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1):: Word64) in
    if Bool
neg then - Int
val else Int
val


-- | average of list of numbers
average :: (Real a, Fractional b) => [a] -> b
average :: forall a b. (Real a, Fractional b) => [a] -> b
average [a]
xs = a -> b
forall a b. (Real a, Fractional b) => a -> b
realToFrac ([a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a]
xs) b -> b -> b
forall a. Fractional a => a -> a -> a
/ [a] -> b
forall i a. Num i => [a] -> i
genericLength [a]
xs

-- crossProduct [[1], [2,3,4], [5,6]] == [[1,2,5],[1,3,5],[1,4,5],[1,2,6],[1,3,6],[1,4,6]]
-- The size of a crossProduct [x_0,x_1,x_i] is the number of produced lists |x_0|*|x_1|*...*|x_i| times the size of each list i.
crossProduct :: [[a]] -> [[a]]
crossProduct :: forall a. [[a]] -> [[a]]
crossProduct []       = [[]]
crossProduct ([a]
as:[[a]]
ass) = [ a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
bs | a
b <- [a]
as, [a]
bs <- [[a]] -> [[a]]
forall a. [[a]] -> [[a]]
crossProduct [[a]]
ass ]

crossProduct_size :: [t a] -> Int
crossProduct_size [t a]
x = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([t a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [t a]
x Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (t a -> Int) -> [t a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [t a]
x) 

neFromList :: Ord a => [a] -> NES.NESet a
neFromList :: forall a. Ord a => [a] -> NESet a
neFromList  = Set a -> NESet a
forall a. Set a -> NESet a
NES.unsafeFromSet (Set a -> NESet a) -> ([a] -> Set a) -> [a] -> NESet a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList
neSetToList :: NESet a -> [a]
neSetToList = Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> [a]) -> (NESet a -> Set a) -> NESet a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NESet a -> Set a
forall a. NESet a -> Set a
NES.toSet


-- Partition a set into equivalence classes
-- NOTE: for lists over Ord elements, one an do this more efficiently
quotientBy :: Ord a => (a -> a -> Bool) -> S.Set a -> S.Set (S.Set a)
quotientBy :: forall a. Ord a => (a -> a -> Bool) -> Set a -> Set (Set a)
quotientBy a -> a -> Bool
eq Set a
s =
  case Set a -> Maybe (a, Set a)
forall a. Set a -> Maybe (a, Set a)
S.minView Set a
s of
    Maybe (a, Set a)
Nothing     -> Set (Set a)
forall a. Set a
S.empty
    Just (a
a,Set a
s') ->
      let (Set a
group,Set a
remainder) = (a -> Bool) -> Set a -> (Set a, Set a)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
S.partition (a -> a -> Bool
eq a
a) Set a
s' in
        Set a -> Set (Set a) -> Set (Set a)
forall a. Ord a => a -> Set a -> Set a
S.insert (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
a Set a
group) (Set (Set a) -> Set (Set a)) -> Set (Set a) -> Set (Set a)
forall a b. (a -> b) -> a -> b
$ (a -> a -> Bool) -> Set a -> Set (Set a)
forall a. Ord a => (a -> a -> Bool) -> Set a -> Set (Set a)
quotientBy a -> a -> Bool
eq Set a
remainder

quotientByL :: Ord a => (a -> a -> Bool) -> [a] -> [[a]]
quotientByL :: forall a. Ord a => (a -> a -> Bool) -> [a] -> [[a]]
quotientByL a -> a -> Bool
eq []     = []
quotientByL a -> a -> Bool
eq (a
a:[a]
as) = 
  let ([a]
group,[a]
remainder) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (a -> a -> Bool
eq a
a) [a]
as in
    (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
group) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: (a -> a -> Bool) -> [a] -> [[a]]
forall a. Ord a => (a -> a -> Bool) -> [a] -> [[a]]
quotientByL a -> a -> Bool
eq [a]
remainder


-- | Sign-extension from 32 to 64 bits
sextend_32_64 :: a -> a
sextend_32_64 a
w = if a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w Int
31 then (a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x00000000FFFFFFFF) a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
0xFFFFFFFF00000000 else (a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x00000000FFFFFFFF)
-- | Sign-extension from 16 to 64 bits
sextend_16_64 :: a -> a
sextend_16_64 a
w = if a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w Int
15 then (a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x000000000000FFFF) a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
0xFFFFFFFFFFFF0000 else (a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x000000000000FFFF)
-- | Sign-extension from 8 to 64 bits
sextend_8_64 :: a -> a
sextend_8_64  a
w = if a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w Int
7  then (a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x00000000000000FF) a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
0xFFFFFFFFFFFFFF00 else (a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x00000000000000FF)

-- | Sign-extension from 16 to 32 bits
sextend_16_32 :: a -> a
sextend_16_32  a
w = if a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w Int
15  then (a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x000000000000FFFF) a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
0x00000000FFFF0000 else (a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x000000000000FFFF)
-- | Sign-extension from 8 to 32 bits
sextend_8_32 :: a -> a
sextend_8_32  a
w = if a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w Int
7  then (a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x00000000000000FF) a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
0x00000000FFFFFF00 else (a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x00000000000000FF)

-- | Sign-extension from 8 to 16 bits
sextend_8_16 :: a -> a
sextend_8_16 a
w = if a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w Int
7  then (a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x00000000000000FF) a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
0x000000000000FF00 else (a
w a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x00000000000000FF)




round2dp :: Double -> Double
round2dp :: Double -> Double
round2dp Double
x = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1e2) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e2


--------------------------------------------
-- | Generic graph with ints as vertices.
--------------------------------------------
data Graph = Edges (IM.IntMap IS.IntSet)
  deriving ((forall x. Graph -> Rep Graph x)
-> (forall x. Rep Graph x -> Graph) -> Generic Graph
forall x. Rep Graph x -> Graph
forall x. Graph -> Rep Graph x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Graph -> Rep Graph x
from :: forall x. Graph -> Rep Graph x
$cto :: forall x. Rep Graph x -> Graph
to :: forall x. Rep Graph x -> Graph
Generic,Int -> Graph -> ShowS
[Graph] -> ShowS
Graph -> String
(Int -> Graph -> ShowS)
-> (Graph -> String) -> ([Graph] -> ShowS) -> Show Graph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Graph -> ShowS
showsPrec :: Int -> Graph -> ShowS
$cshow :: Graph -> String
show :: Graph -> String
$cshowList :: [Graph] -> ShowS
showList :: [Graph] -> ShowS
Show)

instance Cereal.Serialize Graph
instance NFData Graph


-- | add edges from v to all vertices vs
graph_add_edges :: Graph -> Int -> IntSet -> Graph
graph_add_edges (Edges IntMap IntSet
es) Int
v IntSet
vs = IntMap IntSet -> Graph
Edges (IntMap IntSet -> Graph) -> IntMap IntSet -> Graph
forall a b. (a -> b) -> a -> b
$ (IntSet -> IntSet -> IntSet)
-> IntMap IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntSet -> IntSet -> IntSet
IS.union ((Maybe IntSet -> Maybe IntSet)
-> Int -> IntMap IntSet -> IntMap IntSet
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe IntSet -> Maybe IntSet
alter Int
v IntMap IntSet
es) IntMap IntSet
empty_edges
 where
  alter :: Maybe IntSet -> Maybe IntSet
alter Maybe IntSet
Nothing    = IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just (IntSet -> Maybe IntSet) -> IntSet -> Maybe IntSet
forall a b. (a -> b) -> a -> b
$ IntSet
vs
  alter (Just IntSet
vs') = IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just (IntSet -> Maybe IntSet) -> IntSet -> Maybe IntSet
forall a b. (a -> b) -> a -> b
$ IntSet -> IntSet -> IntSet
IS.union IntSet
vs IntSet
vs'

  empty_edges :: IntMap IntSet
empty_edges = [(Int, IntSet)] -> IntMap IntSet
forall a. [(Int, a)] -> IntMap a
IM.fromList ([(Int, IntSet)] -> IntMap IntSet)
-> [(Int, IntSet)] -> IntMap IntSet
forall a b. (a -> b) -> a -> b
$ [Int] -> [IntSet] -> [(Int, IntSet)]
forall a b. [a] -> [b] -> [(a, b)]
zip (IntSet -> [Int]
IS.toList IntSet
vs) (IntSet -> [IntSet]
forall a. a -> [a]
repeat IntSet
IS.empty)

-- | delete all edges with v as parent or child
graph_delete :: Graph -> Int -> Graph
graph_delete (Edges IntMap IntSet
es) Int
v = IntMap IntSet -> Graph
Edges (IntMap IntSet -> Graph) -> IntMap IntSet -> Graph
forall a b. (a -> b) -> a -> b
$ Int -> IntMap IntSet -> IntMap IntSet
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
v (IntMap IntSet -> IntMap IntSet) -> IntMap IntSet -> IntMap IntSet
forall a b. (a -> b) -> a -> b
$ (IntSet -> IntSet) -> IntMap IntSet -> IntMap IntSet
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map (Int -> IntSet -> IntSet
IS.delete Int
v) IntMap IntSet
es

-- | is v parent of an edge?
graph_is_parent :: Graph -> Int -> Bool
graph_is_parent (Edges IntMap IntSet
es) Int
v = Int -> IntMap IntSet -> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
v IntMap IntSet
es

-- | is v a vertex in the graph?
graph_is_vertex :: Graph -> Int -> Bool
graph_is_vertex (Edges IntMap IntSet
es) Int
v = Int -> IntMap IntSet -> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
v IntMap IntSet
es Bool -> Bool -> Bool
|| (IntSet -> Bool) -> IntMap IntSet -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int -> IntSet -> Bool
IS.member Int
v) IntMap IntSet
es

-- | is (v0,v1) an edge?
graph_is_edge :: Graph -> Int -> Int -> Bool
graph_is_edge (Edges IntMap IntSet
es) Int
v0 Int
v1  =
  case Int -> IntMap IntSet -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v0 IntMap IntSet
es of
    Maybe IntSet
Nothing -> Bool
False
    Just IntSet
vs -> Int -> IntSet -> Bool
IS.member Int
v1 IntSet
vs


-- | Find an end (terminal node) reachable from the given node v0
try_find_end_node_from_node :: Graph -> Int -> Maybe Int
try_find_end_node_from_node (Edges IntMap IntSet
es) Int
v0 = State IntSet (Maybe Int) -> IntSet -> Maybe Int
forall s a. State s a -> s -> a
evalState (Int -> State IntSet (Maybe Int)
go Int
v0) IntSet
IS.empty
 where
  go :: Int -> State IS.IntSet (Maybe Int)
  go :: Int -> State IntSet (Maybe Int)
go Int
v = do
    IntSet
visited <- StateT IntSet Identity IntSet
forall s (m :: * -> *). MonadState s m => m s
get
    if Int
v Int -> IntSet -> Bool
`IS.member` IntSet
visited then
      Maybe Int -> State IntSet (Maybe Int)
forall a. a -> StateT IntSet Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> State IntSet (Maybe Int))
-> Maybe Int -> State IntSet (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Maybe Int
forall a. Maybe a
Nothing
    else case Int -> IntMap IntSet -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap IntSet
es of
      Maybe IntSet
Nothing -> Maybe Int -> State IntSet (Maybe Int)
forall a. a -> StateT IntSet Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
      Just IntSet
vs -> 
        if IntSet -> Bool
IS.null IntSet
vs then
          Maybe Int -> State IntSet (Maybe Int)
forall a. a -> StateT IntSet Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> State IntSet (Maybe Int))
-> Maybe Int -> State IntSet (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
v
        else do
          (IntSet -> IntSet) -> StateT IntSet Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IntSet -> IntSet) -> StateT IntSet Identity ())
-> (IntSet -> IntSet) -> StateT IntSet Identity ()
forall a b. (a -> b) -> a -> b
$ Int -> IntSet -> IntSet
IS.insert Int
v
          (Int -> State IntSet (Maybe Int))
-> [Int] -> State IntSet (Maybe Int)
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM Int -> State IntSet (Maybe Int)
go ([Int] -> State IntSet (Maybe Int))
-> [Int] -> State IntSet (Maybe Int)
forall a b. (a -> b) -> a -> b
$ IntSet -> [Int]
IS.toList IntSet
vs

instance IntGraph Graph where
  intgraph_post :: Graph -> Int -> IntSet
intgraph_post (Edges IntMap IntSet
es) Int
v =
    IntSet -> Maybe IntSet -> IntSet
forall a. a -> Maybe a -> a
fromMaybe IntSet
IS.empty (Int -> IntMap IntSet -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap IntSet
es)
  intgraph_V :: Graph -> IntSet
intgraph_V (Edges IntMap IntSet
es) = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IS.unions ([IntSet] -> IntSet) -> [IntSet] -> IntSet
forall a b. (a -> b) -> a -> b
$ IntMap IntSet -> IntSet
forall a. IntMap a -> IntSet
IM.keysSet IntMap IntSet
es IntSet -> [IntSet] -> [IntSet]
forall a. a -> [a] -> [a]
: IntMap IntSet -> [IntSet]
forall a. IntMap a -> [a]
IM.elems IntMap IntSet
es



------------------------------------------
-- Serialization                        --
------------------------------------------



instance (Ord a, Cereal.Serialize a) => Cereal.Serialize (NES.NESet a) where
    put :: Putter (NESet a)
put = Putter a -> Putter (NESet a)
forall a. Putter a -> Putter (NESet a)
putNESetOf Putter a
forall t. Serialize t => Putter t
Cereal.put
    get :: Get (NESet a)
get = Get a -> Get (NESet a)
forall a. Ord a => Get a -> Get (NESet a)
getNESetOf Get a
forall t. Serialize t => Get t
Cereal.get


putNESetOf :: Cereal.Putter a -> Cereal.Putter (NES.NESet a)
putNESetOf :: forall a. Putter a -> Putter (NESet a)
putNESetOf Putter a
pa = Putter a -> Putter (Set a)
forall a. Putter a -> Putter (Set a)
putSetOf Putter a
pa Putter (Set a) -> (NESet a -> Set a) -> NESet a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NESet a -> Set a
forall a. NESet a -> Set a
NES.toSet
{-# INLINE putNESetOf #-}

-- | Read as a list of elements.
getNESetOf :: Ord a => Cereal.Get a -> Cereal.Get (NES.NESet a)
getNESetOf :: forall a. Ord a => Get a -> Get (NESet a)
getNESetOf Get a
m = Set a -> NESet a
forall a. Set a -> NESet a
NES.unsafeFromSet (Set a -> NESet a) -> Get (Set a) -> Get (NESet a)
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Get a -> Get (Set a)
forall a. Ord a => Get a -> Get (Set a)
getSetOf Get a
m



------------------------------------------
-- Colors                               --
------------------------------------------


-- | decide whether text should be white or black based on background color
hex_color_of_text :: String -> String
hex_color_of_text :: ShowS
hex_color_of_text String
bgcolor =
  let red :: Double
red   = (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Int
forall a. (Eq a, Num a) => String -> a
readHex' [String
bgcolorString -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!!Int
1,String
bgcolorString -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!!Int
2] :: Int) :: Double)
      green :: Double
green = (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Int
forall a. (Eq a, Num a) => String -> a
readHex' [String
bgcolorString -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!!Int
3,String
bgcolorString -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!!Int
4] :: Int) :: Double)
      blue :: Double
blue  = (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Int
forall a. (Eq a, Num a) => String -> a
readHex' [String
bgcolorString -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!!Int
5,String
bgcolorString -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!!Int
6] :: Int) :: Double) in
    if (Double
redDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
0.299 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
greenDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
0.587 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
blueDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
0.114) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
186 then
      String
"#000000"
    else
      String
"#ffffff"

-- | A list of RGB colors
hex_colors :: [String]
hex_colors = [
  String
"#000000",
  String
"#FF0000",
  String
"#00FF00",
  String
"#0000FF",
  String
"#FFFF00",
  String
"#00FFFF",
  String
"#FF00FF",
  String
"#808080",
  String
"#FF8080",
  String
"#80FF80",
  String
"#8080FF",
  String
"#008080",
  String
"#800080",
  String
"#808000",
  String
"#FFFF80",
  String
"#80FFFF",
  String
"#FF80FF",
  String
"#FF0080",
  String
"#80FF00",
  String
"#0080FF",
  String
"#00FF80",
  String
"#8000FF",
  String
"#FF8000",
  String
"#000080",
  String
"#800000",
  String
"#008000",
  String
"#404040",
  String
"#FF4040",
  String
"#40FF40",
  String
"#4040FF",
  String
"#004040",
  String
"#400040",
  String
"#404000",
  String
"#804040",
  String
"#408040",
  String
"#404080",
  String
"#FFFF40",
  String
"#40FFFF",
  String
"#FF40FF",
  String
"#FF0040",
  String
"#40FF00",
  String
"#0040FF",
  String
"#FF8040",
  String
"#40FF80",
  String
"#8040FF",
  String
"#00FF40",
  String
"#4000FF",
  String
"#FF4000",
  String
"#000040",
  String
"#400000",
  String
"#004000",
  String
"#008040",
  String
"#400080",
  String
"#804000",
  String
"#80FF40",
  String
"#4080FF",
  String
"#FF4080",
  String
"#800040",
  String
"#408000",
  String
"#004080",
  String
"#808040",
  String
"#408080",
  String
"#804080",
  String
"#C0C0C0",
  String
"#FFC0C0",
  String
"#C0FFC0",
  String
"#C0C0FF",
  String
"#00C0C0",
  String
"#C000C0",
  String
"#C0C000",
  String
"#80C0C0",
  String
"#C080C0",
  String
"#C0C080",
  String
"#40C0C0",
  String
"#C040C0",
  String
"#C0C040",
  String
"#FFFFC0",
  String
"#C0FFFF",
  String
"#FFC0FF",
  String
"#FF00C0",
  String
"#C0FF00",
  String
"#00C0FF",
  String
"#FF80C0",
  String
"#C0FF80",
  String
"#80C0FF",
  String
"#FF40C0",
  String
"#C0FF40",
  String
"#40C0FF",
  String
"#00FFC0",
  String
"#C000FF",
  String
"#FFC000",
  String
"#0000C0",
  String
"#C00000",
  String
"#00C000",
  String
"#0080C0",
  String
"#C00080",
  String
"#80C000",
  String
"#0040C0",
  String
"#C00040",
  String
"#40C000",
  String
"#80FFC0",
  String
"#C080FF",
  String
"#FFC080",
  String
"#8000C0",
  String
"#C08000",
  String
"#00C080",
  String
"#8080C0",
  String
"#C08080",
  String
"#80C080",
  String
"#8040C0",
  String
"#C08040",
  String
"#40C080",
  String
"#40FFC0",
  String
"#C040FF",
  String
"#FFC040",
  String
"#4000C0",
  String
"#C04000",
  String
"#00C040",
  String
"#4080C0",
  String
"#C04080",
  String
"#80C040",
  String
"#4040C0",
  String
"#C04040",
  String
"#40C040",
  String
"#202020",
  String
"#FF2020",
  String
"#20FF20"
 ]


------------------------------------------
-- PREDICATES                           --
------------------------------------------

allp :: [a -> Bool] -> a -> Bool
allp :: forall a. [a -> Bool] -> a -> Bool
allp [a -> Bool]
ps a
a = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (\a -> Bool
pred -> a -> Bool
pred a
a) ((a -> Bool) -> Bool) -> [a -> Bool] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a -> Bool]
ps