loopy-0.0: Graph.hs

--need to change matrix types
module Graph where

import Types
import System.IO.Unsafe(unsafePerformIO)

import Data.List
import Data.IntMap(IntMap)
import qualified Data.IntMap as IntMap
import Control.Monad
import Data.Bits

type Graph = [(Int,Int)] --list of edges
type Graph2 = IntMap (IntMap Chunk, IntMap Chunk)
type Loop = [Int]
type Size = Int

graphFromMatrix :: Int -> Matrix Double -> Graph
graphFromMatrix n m = [(i,j) | i <- [0..n-1], j <- [0..n-1], i /= j, let v = m!!i!!j, v /= 0]


-- Index is the lowest of src and dest link
-- min (src, dest)

data Chunk = Nil
           | Atom Int
           | CrossL Chunk Int
           | CrossR Int Chunk
           | Cross Chunk Int Chunk
           | Or Chunk Chunk
             deriving Show

cross Nil i Nil = Atom i
cross Nil i x = CrossR i x
cross x i Nil = CrossL x i
cross x i y = Cross x i y


loops :: Graph -> [Loop]
loops g = deleteNodes $ graph2 g


graph2 :: Graph -> Graph2
graph2 xs = addLinks IntMap.empty [(a,Nil,b) | (a,b) <- xs]


addLinks :: Graph2 -> [(Int,Chunk,Int)] -> Graph2
addLinks = foldl addLink

addLink :: Graph2 -> (Int,Chunk,Int) -> Graph2
addLink g (src,i,dest) | src < dest = IntMap.insertWith add src  (IntMap.empty, IntMap.singleton dest i) g
    where add _ (x,y) = (x, IntMap.insertWith Or dest i y)
addLink g (src,i,dest) | otherwise  = IntMap.insertWith add dest (IntMap.singleton src i , IntMap.empty) g
    where add _ (x,y) = (IntMap.insertWith Or src i x , y)


deleteNodes :: Graph2 -> [Loop]
deleteNodes g | IntMap.null g = []
              | otherwise = a ++ deleteNodes b
              where (a,b) = deleteNode g


deleteNode :: Graph2 -> ([Loop], Graph2)
deleteNode g = (concatMap flatten [cross Nil i c | (i,c,_) <- lop], addLinks g2 new)
    where
        (lop,new) = partition (\(i,_,j) -> i == j) [(src,cross srci k desti,dest) | (src,srci) <- lhss, (dest,desti) <- rhss]
        (lhss,rhss) = (IntMap.toList lhs, IntMap.toList rhs)
        Just ((k,(lhs,rhs)),g2) = IntMap.minViewWithKey g



flatten :: Chunk -> [Loop]
flatten x = map snd . f $ x
    where
        -- the bits in the Integer represent which indecies are present
        f :: Chunk -> [(Integer, Loop)]
        f Nil = [(0, [])]
        f (Or a b) = f a ++ f b
        f (Cross as b cs) =
            [(aci, a ++ c)
                | let ass = [(ai,a) | (ai,a) <- f as, not $ testBit ai b]
                , (ciPre,cPre) <- f cs, let c = b : cPre
                , not $ testBit ciPre b, let ci = setBit ciPre b
                , (ai,a) <- ass
                , ai .&. ci == 0, let aci = ai .|. ci]

        -- specialisations of Cross
        f (Atom b) = [(bit b, [b])]
        f (CrossR b cs) =
            [(ci, c)
                | (ciPre,cPre) <- f cs, let c = b : cPre
                , not $ testBit ciPre b, let ci = setBit ciPre b]
        f (CrossL as b) =
            [(ai, a)
                | (aiPre,aPre) <- f as, let a = aPre ++ [b]
                , not $ testBit aiPre b, let ai = setBit aiPre b]
--removes any loops containing detritus
detLoops :: Int -> [Loop] -> [Loop]
detLoops detRow [] = []
detLoops detRow ls = if (elem detRow (head ls)) then (detLoops detRow (tail ls)) else (ls ++  (detLoops detRow $ tail ls))

{-
detLoops2 :: Int -> [String] -> [String]
detLoops2 detRow [] = []
detLoops2 detRow ls = if (elem detRow (l)) then (detLoops2 detRow (tail ls)) else (ls ++  (detLoops2 detRow $ tail ls))
	where l = read l2 :: Loop
	      l2 = (head ls)!!0


flatten :: Chunk -> [Loop]
flatten = map snd . f
    where
        f :: Chunk -> [([Int], Loop)]
        f Nil = [([], [])]
        f (Or a b) = f a ++ f b
        f (Cross as b cs) =
            [(aci, a ++ c)
                | let ass = filter (notElemInt b . fst) $ f as
                , (ciPre,cPre) <- f cs, let c = b : cPre
                , b `notElemInt` ciPre, let ci = insertInt b ciPre
                , (ai,a) <- ass
                , disjoint ai ci, let aci = merge ai ci]


notElemInt :: Int -> [Int] -> Bool
notElemInt x [] = True
notElemInt x (y:ys) = x /= y && notElemInt x ys


insertInt :: Int -> [Int] -> [Int]
insertInt x (y:ys) | x < y = x : y : ys
                   | otherwise = y : insertInt x ys
insertInt x [] = [x]


merge :: [Int] -> [Int] -> [Int]
merge (x:xs) (y:ys)
    | x < y = x : merge xs (y:ys)
    | otherwise = y : merge (x:xs) ys
merge xs [] = xs
merge [] ys = ys


disjoint :: [Int] -> [Int] -> Bool
disjoint xs [] = True
disjoint [] ys = True
disjoint (x:xs) (y:ys) = case compare x y of
    EQ -> False
    LT -> disjoint xs (y:ys)
    GT -> disjoint (x:xs) ys
-}





loopsOld :: Graph -> [Loop]
loopsOld g = f [(x,[],y) | (x,y) <- g]
    where
        f [] = out "done" []
        f xs = out (length res, length xs) $ res ++ f xs4
            where
                res = [a:b | (a,b,c) <- loops]
                kill = fst3 $ head xs
                (from,xs2) = partition ((==) kill . fst3) xs
                xs3 = concatMap add xs2
                (loops,xs4) = partition isLoop xs3

                add (a,b,c) | c == kill = [(a,b ++ d:e,f) | (d,e,f) <- from, disjointed b e]
                add x = [x]

        isLoop (a,b,c) = a == c


fst3 (a,b,c) = a

disjointed x y = null $ x `intersect` y



{-# NOINLINE out #-}
out x y = unsafePerformIO $ print x >> return y