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

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


module Base where

import Algorithm.SCC

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.Maybe (mapMaybe, fromMaybe,fromJust)
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)
import Control.DeepSeq


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

-- | 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, Show 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, Show 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, Show 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     = [Key] -> String
forall a. (Integral a, Show a) => [a] -> String
showHex_list ([Key] -> String) -> (IntSet -> [Key]) -> IntSet -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Key]
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, Show a) => a -> String
showHex a
v
-- | Read an int from a string storing a hex.
readHex' :: (Eq a, Num a) => String -> a
readHex' :: 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. [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

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

-- | use a default value in case of @Nothing@
orElse :: Eq a => Maybe a -> a -> a
orElse :: 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 :: 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

-- | 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  


-- | 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 :: [a] -> [a] -> Maybe Key
findString [a]
search [a]
str = ([a] -> Bool) -> [[a]] -> Maybe Key
forall a. (a -> Bool) -> [a] -> Maybe Key
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. [a] -> a
head String
str Char -> ShowS
forall a. a -> [a] -> [a]
: String -> ShowS
takeUntilString String
search (ShowS
forall a. [a] -> [a]
tail String
str)


-- | Strip outer parentheses from a string, if it has them.
strip_parentheses :: ShowS
strip_parentheses String
s = if String -> Key
forall (t :: * -> *) a. Foldable t => t a -> Key
length String
s Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
0 Bool -> Bool -> Bool
&& String -> Char
forall a. [a] -> a
head String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& String -> Char
forall a. [a] -> a
last String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' then ShowS
forall a. [a] -> [a]
init ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [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 :: (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 -> Key -> Word64
forall a. Bits a => a -> Key -> a
shift ([Word8] -> Word64
bytes_to_word [Word8]
ws) Key
8

-- | Convert first @n@ bytes of a word to an integer.
-- Assume @n<8@.
word_to_sint :: Int -> Word64 -> Int
word_to_sint :: Key -> Word64 -> Key
word_to_sint Key
si Word64
w =
  let neg :: Bool
neg = Word64 -> Key -> Bool
forall a. Bits a => a -> Key -> Bool
testBit Word64
w (Key
siKey -> Key -> Key
forall a. Num a => a -> a -> a
*Key
8Key -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1)
      val :: Key
val = Word64 -> Key
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 -> Key -> Word64
forall a. Bits a => a -> Key -> a
clearBit Word64
w (Key
siKey -> Key -> Key
forall a. Num a => a -> a -> a
*Key
8Key -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1):: Word64) in
    if Bool
neg then - Key
val else Key
val


-- | average of list of numbers
average :: (Real a, Fractional b) => [a] -> b
average :: [a] -> b
average [a]
xs = a -> b
forall a b. (Real a, Fractional b) => a -> b
realToFrac ([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 :: [[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] -> Key
crossProduct_size [t a]
x = [Key] -> Key
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([t a] -> Key
forall (t :: * -> *) a. Foldable t => t a -> Key
length [t a]
x Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: (t a -> Key) -> [t a] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map t a -> Key
forall (t :: * -> *) a. Foldable t => t a -> Key
length [t a]
x) 

neFromList :: Ord a => [a] -> NES.NESet a
neFromList :: [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 :: (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

--------------------------------------------
-- | 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
$cto :: forall x. Rep Graph x -> Graph
$cfrom :: forall x. Graph -> Rep Graph x
Generic,Key -> Graph -> ShowS
[Graph] -> ShowS
Graph -> String
(Key -> Graph -> ShowS)
-> (Graph -> String) -> ([Graph] -> ShowS) -> Show Graph
forall a.
(Key -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Graph] -> ShowS
$cshowList :: [Graph] -> ShowS
show :: Graph -> String
$cshow :: Graph -> String
showsPrec :: Key -> Graph -> ShowS
$cshowsPrec :: Key -> Graph -> ShowS
Show)

instance Cereal.Serialize Graph
instance NFData Graph


-- | add edges from v to all vertices vs
graph_add_edges :: Graph -> Key -> IntSet -> Graph
graph_add_edges (Edges IntMap IntSet
es) Key
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)
-> Key -> IntMap IntSet -> IntMap IntSet
forall a. (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a
IM.alter Maybe IntSet -> Maybe IntSet
alter Key
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 = [(Key, IntSet)] -> IntMap IntSet
forall a. [(Key, a)] -> IntMap a
IM.fromList ([(Key, IntSet)] -> IntMap IntSet)
-> [(Key, IntSet)] -> IntMap IntSet
forall a b. (a -> b) -> a -> b
$ [Key] -> [IntSet] -> [(Key, IntSet)]
forall a b. [a] -> [b] -> [(a, b)]
zip (IntSet -> [Key]
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 -> Key -> Graph
graph_delete (Edges IntMap IntSet
es) Key
v = IntMap IntSet -> Graph
Edges (IntMap IntSet -> Graph) -> IntMap IntSet -> Graph
forall a b. (a -> b) -> a -> b
$ Key -> IntMap IntSet -> IntMap IntSet
forall a. Key -> IntMap a -> IntMap a
IM.delete Key
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 (Key -> IntSet -> IntSet
IS.delete Key
v) IntMap IntSet
es

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

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

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


instance IntGraph Graph where
  intgraph_post :: Graph -> Key -> IntSet
intgraph_post (Edges IntMap IntSet
es) Key
v =
    IntSet -> Maybe IntSet -> IntSet
forall a. a -> Maybe a -> a
fromMaybe IntSet
IS.empty (Key -> IntMap IntSet -> Maybe IntSet
forall a. Key -> IntMap a -> Maybe a
IM.lookup Key
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


-- | retrieve a non-trivial SCC, if any exists
graph_nontrivial_scc :: Graph -> IntSet
graph_nontrivial_scc g :: Graph
g@(Edges IntMap IntSet
es) =
  let sccs :: [IntSet]
sccs             = Graph -> IntSet -> [IntSet]
forall g. IntGraph g => g -> IntSet -> [IntSet]
all_sccs Graph
g IntSet
IS.empty
      nontrivial_sccs :: [IntSet]
nontrivial_sccs  = (IntSet -> Bool) -> [IntSet] -> [IntSet]
forall a. (a -> Bool) -> [a] -> [a]
filter IntSet -> Bool
is_non_trivial [IntSet]
sccs
      nontrivial_scc :: IntSet
nontrivial_scc   = (IntSet -> IntSet -> Ordering) -> [IntSet] -> IntSet
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((IntSet -> Key) -> IntSet -> IntSet -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing IntSet -> Key
IS.size) [IntSet]
sccs in
    IntSet
nontrivial_scc -- trace ("Found SCC of mutually recursive function entries: " ++ showHex_set nontrivial_scc) nontrivial_scc
 where
  is_non_trivial :: IS.IntSet -> Bool
  is_non_trivial :: IntSet -> Bool
is_non_trivial IntSet
scc = IntSet -> Key
IS.size IntSet
scc Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
1 Bool -> Bool -> Bool
|| Graph -> Key -> Key -> Bool
graph_is_edge Graph
g ([Key] -> Key
forall a. [a] -> a
head ([Key] -> Key) -> [Key] -> Key
forall a b. (a -> b) -> a -> b
$ IntSet -> [Key]
IS.toList IntSet
scc) ([Key] -> Key
forall a. [a] -> a
head ([Key] -> Key) -> [Key] -> Key
forall a b. (a -> b) -> a -> b
$ IntSet -> [Key]
IS.toList IntSet
scc)



-- | find next vertex to consider: either a terminal vertex (if any) or the head of an SCC
graph_find_next :: Graph -> Maybe Int
graph_find_next :: Graph -> Maybe Key
graph_find_next g :: Graph
g@(Edges IntMap IntSet
es) =
  if IntMap IntSet -> Bool
forall a. IntMap a -> Bool
IM.null IntMap IntSet
es then
    Maybe Key
forall a. Maybe a
Nothing
  else case ((Key, IntSet) -> Bool) -> [(Key, IntSet)] -> Maybe (Key, IntSet)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (IntSet -> IntSet -> Bool
IS.disjoint (IntMap IntSet -> IntSet
forall a. IntMap a -> IntSet
IM.keysSet IntMap IntSet
es) (IntSet -> Bool)
-> ((Key, IntSet) -> IntSet) -> (Key, IntSet) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, IntSet) -> IntSet
forall a b. (a, b) -> b
snd) ([(Key, IntSet)] -> Maybe (Key, IntSet))
-> [(Key, IntSet)] -> Maybe (Key, IntSet)
forall a b. (a -> b) -> a -> b
$ IntMap IntSet -> [(Key, IntSet)]
forall a. IntMap a -> [(Key, a)]
IM.toList IntMap IntSet
es of
    Maybe (Key, IntSet)
Nothing    -> Key -> Maybe Key
forall a. a -> Maybe a
Just (Key -> Maybe Key) -> Key -> Maybe Key
forall a b. (a -> b) -> a -> b
$ [Key] -> Key
forall a. [a] -> a
head ([Key] -> Key) -> [Key] -> Key
forall a b. (a -> b) -> a -> b
$ IntSet -> [Key]
IS.toList (IntSet -> [Key]) -> IntSet -> [Key]
forall a b. (a -> b) -> a -> b
$ Graph -> IntSet
graph_nontrivial_scc Graph
g -- no terminal vertex
    Just (Key
v,IntSet
_) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
v                               -- terminal vertex


------------------------------------------
-- 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 :: 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) -> Putter (NESet a)
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 :: 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 (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   = (Key -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Key
forall a. (Eq a, Num a) => String -> a
readHex' [String
bgcolorString -> Key -> Char
forall a. [a] -> Key -> a
!!Key
1,String
bgcolorString -> Key -> Char
forall a. [a] -> Key -> a
!!Key
2] :: Int) :: Double)
      green :: Double
green = (Key -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Key
forall a. (Eq a, Num a) => String -> a
readHex' [String
bgcolorString -> Key -> Char
forall a. [a] -> Key -> a
!!Key
3,String
bgcolorString -> Key -> Char
forall a. [a] -> Key -> a
!!Key
4] :: Int) :: Double)
      blue :: Double
blue  = (Key -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Key
forall a. (Eq a, Num a) => String -> a
readHex' [String
bgcolorString -> Key -> Char
forall a. [a] -> Key -> a
!!Key
5,String
bgcolorString -> Key -> Char
forall a. [a] -> Key -> a
!!Key
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 :: [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