RandomCompositionGraph.hs

{-| Module  : FiniteCategories
Description : Randomly generated composition graphs.
Copyright   : Guillaume Sabbagh 2021
License     : GPL-3
Maintainer  : guillaumesabbagh@protonmail.com
Stability   : experimental
Portability : portable

This module provide functions to generate randomly composition graphs.
It is an easy and fast way to generate a lot of finite categories.
It can be used to test functions, to generate examples or to test hypothesis.
-}

module RandomCompositionGraph.RandomCompositionGraph 
(
    mkRandomCompositionGraph,
    defaultMkRandomCompositionGraph
)
where
    import FiniteCategory.FiniteCategory 
    import CompositionGraph.CompositionGraph        (Graph(..), CGMorphism(..), CompositionLaw(..), CompositionGraph(..), Arrow(..), mkCompositionGraph, isGen, isComp)
    import System.Random                            (RandomGen, uniformR)
    import Data.Maybe                               (isNothing, fromJust)
    import Utils.AssociationList
    import Utils.Sample
    import Utils.Tuple

    -- | Find first order composites arrows in a composition graph.
    compositeMorphisms :: (Eq a, Eq b, Show a) => CompositionGraph a b -> [CGMorphism a b]
    compositeMorphisms c = [g @ f | f <- genArrows c, g <- genArFrom c (target f), not (elem (g @ f) (genAr c (source f) (target g)))]

    -- | Merge two nodes.
    mergeNodes :: (Eq a) => CompositionGraph a b -> a -> a -> CompositionGraph a b
    mergeNodes cg@CompositionGraph{graph=g@(objs,ars),law=l} s t
        | not (elem s objs) = error "mapped but not in rcg."
        | not (elem t objs) = error "mapped to but not in rcg."
        | s == t = cg
        | otherwise = CompositionGraph {graph=(filter (/=s) objs,replaceArrow <$> ars), law=newLaw}
        where
            replace x = if x == s then t else x
            replaceArrow (s1,t1,l1) = (replace s1, replace t1, l1)
            newLaw = (\(k,v) -> (replaceArrow <$> k, replaceArrow <$> v)) <$> l
    
    -- | Merge two morphisms of a composition graph, the morphism mapped should be composite, the morphism mapped to should be a generator.
    mergeMorphisms :: (Eq a, Eq b) => CompositionGraph a b -> CGMorphism a b -> CGMorphism a b -> CompositionGraph a b
    mergeMorphisms cg@CompositionGraph{graph=g,law=l} s@CGMorphism{path=p1@(s1,rp1,t1),compositionLaw=l1} t@CGMorphism{path=p2@(s2,rp2,t2),compositionLaw=l2}
        | (isGen s) = error "Generator at the start of a merge"
        | (isComp t) = error "Composite at the end of a merge"
        | s1 == t1 =  mergeNodes CompositionGraph{graph=g, law=newLaw} (source s) (source t)
        | s1 == t2 = mergeNodes (mergeNodes CompositionGraph{graph=g, law=newLaw} (source s) (source t)) (target s) (source t)
        | otherwise = mergeNodes (mergeNodes CompositionGraph{graph=g, law=newLaw} (source s) (source t)) (target s) (target t) where
        newLaw = ((replaceArrow <$> rp1,replaceArrow <$> rp2):((\(k,v) -> (replaceArrow <$> k, replaceArrow <$> v)) <$> l))
            where
                replace x = if x == s1 then s2 else (if x == t1 then t2 else x)
                replaceArrow (s3,t3,l3) = (replace s3, replace t3, l3)
    
    -- | Checks associativity of a composition graph.
    checkAssociativity :: (Eq a, Eq b, Show a) => CompositionGraph a b -> Bool
    checkAssociativity cg = foldr (&&) True [checkTriplet (f,g,h) | f <- genArrows cg, g <- genArFrom cg (target f), h <- genArFrom cg (target g)]
        where
            checkTriplet (f,g,h) = (h @ g) @ f == h @ (g @ f)
        
    -- | Find all composite arrows and try to map them to generating arrows. 
    identifyCompositeToGen :: (RandomGen g, Eq a, Eq b, Show a) => CompositionGraph a b -> Int -> g -> (Maybe (CompositionGraph a b), g)
    identifyCompositeToGen _ 0 rGen = (Nothing, rGen)
    identifyCompositeToGen cg n rGen
        | not (checkAssociativity cg) = (Nothing, rGen)
        | null compositeMorphs = (Just cg, rGen)
        | otherwise = if isNothing newCG then identifyCompositeToGen cg (n `div` 2) newGen2 else (newCG, newGen2)
        where
            compositeMorphs = compositeMorphisms cg
            morphToMap = (head compositeMorphs)
            (selectedGen,newGen1) = if (source morphToMap == target morphToMap) then pickOne [fs | obj <- ob cg, fs <- (genAr cg obj obj)] rGen else pickOne (genArrows cg) rGen
            (newCG,newGen2) = identifyCompositeToGen (mergeMorphisms cg morphToMap selectedGen) n newGen1 
            
    -- | Algorithm described in `mkRandomCompositionGraph`.
    monoidificationAttempt :: (RandomGen g, Eq a, Eq b, Show a) => CompositionGraph a b -> Int -> g -> (CompositionGraph a b, g, [a])
    monoidificationAttempt cg p g = if isNothing result then (cg,finalGen,[]) else (fromJust result, finalGen, [s,t])
        where
            ([s,t],newGen) = if ((length (ob cg)) > 1) then sample (ob cg) 2 g else (ob cg ++ ob cg,g)
            newCG = mergeNodes cg s t
            (result,finalGen) = identifyCompositeToGen newCG p newGen
    
    -- | Initialize a composition graph with all arrows seperated.
    initRandomCG :: Int -> CompositionGraph Int Int
    initRandomCG n = CompositionGraph{graph=([0..n+n-1],[((i+i),(i+i+1), i) | i <- [0..n]]),law=[]}
    
    -- | Generates a random composition graph.
    --
    -- We use the fact that a category is a generalized monoid.
    --
    -- We try to create a composition law of a monoid greedily.
    --
    -- To get a category, we begin with a category with all arrows seperated and not composing with each other. 
    -- It is equivalent to the monoid with an empty composition law.
    --
    -- Then, a monoidification attempt is the following algorihm :
    --
    -- 1. Pick two objects, merge them.
    -- 2. While there are composite morphisms, try to merge them with generating arrows.
    -- 3. If it fails, don't change the composition graph.
    -- 4. Else return the new composition graph
    -- 
    -- A monoidification attempt takes a valid category and outputs a valid category, furthermore, the number of arrows is constant
    -- and the number of objects is decreasing (not strictly).
    mkRandomCompositionGraph :: (RandomGen g) => Int -- ^ Number of arrows of the random composition graph.
                                              -> Int -- ^ Number of monoidification attempts, a bigger number will produce more morphisms that will compose but the function will be slower.
                                              -> Int -- ^ Perseverance : how much we pursure an attempt far away to find a law that works, a bigger number will make the attemps more successful, but slower. (When in doubt put 4.)
                                              -> g   -- ^ Random generator.
                                              -> (CompositionGraph Int Int, g)
    mkRandomCompositionGraph nbAr nbAttempts perseverance gen = attempt (initRandomCG nbAr) nbAttempts perseverance gen
        where
            attempt cg 0 _ gen = (cg, gen)
            attempt cg n p gen = attempt newCG (n-1) p newGen
                where
                    (newCG, newGen,_) = (monoidificationAttempt cg p gen)
    
    -- | Creates a random composition graph with default random values.
    --
    -- The number of arrows will be in the interval [1, 20].
    defaultMkRandomCompositionGraph  :: (RandomGen g) => g -> (CompositionGraph Int Int, g)
    defaultMkRandomCompositionGraph g1 = mkRandomCompositionGraph nbArrows (min nbAttempts 20) 4 g3
        where 
            (nbArrows, g2) = uniformR (1,20) g1
            (nbAttempts, g3) = uniformR (0,nbArrows+nbArrows) g2