Created
November 14, 2010 06:26
-
-
Save m2ym/675959 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
import Data.List | |
import Data.Maybe | |
import Data.Graph.Inductive.Graph | |
import Data.Graph.Inductive.Basic | |
import Data.Graph.Inductive.Tree | |
import Data.Graph.Inductive.Internal.RootPath | |
import Data.Graph.Inductive.Query.DFS | |
import Data.Graph.Inductive.Query.MST | |
import Control.Applicative | |
import Control.Monad | |
import Text.Printf | |
import System.Random | |
-- Utilities | |
randomRnIO :: Random a => Int -> (a, a) -> IO [a] | |
randomRnIO n r = sequence $ replicate n (randomRIO r) | |
pathEdges :: Path -> [Edge] | |
pathEdges p = zip p (tail p) | |
-- Spanning Tree Graph | |
type SGr = Gr () () | |
rTreeToGraph :: RTree -> SGr | |
rTreeToGraph t = mkUGraph (nub $ concat t) (nub $ concatMap pathEdges t) | |
lrTreeToGraph :: LRTree b -> SGr | |
lrTreeToGraph = rTreeToGraph . unlabLRTree | |
where | |
unlabLRTree :: LRTree b -> RTree | |
unlabLRTree = map lPathToPath | |
lPathToPath :: LPath a -> Path | |
lPathToPath (LP p) = map fst p | |
msGraph :: Real b => Gr a b -> SGr | |
msGraph = lrTreeToGraph . msTree | |
hamiltonPath :: SGr -> Path | |
hamiltonPath g = let p = udfs' g in last p:p | |
-- Euclidean Metric Graph | |
type Norm = Float | |
type Point = (Int, Int) | |
type EGr = Gr Point Norm | |
type ENode = LNode Point | |
type EEdge = LEdge Norm | |
genEGraph :: Int -> (Int, Int) -> (Int, Int) -> IO EGr | |
genEGraph n xr yr = undir <$> mkEGraph <$> genPoints | |
where | |
genPoints :: IO [(Int, Int)] | |
genPoints = liftM2 zip (randomRnIO n xr) (randomRnIO n yr) | |
mkEGraph :: [Point] -> EGr | |
mkEGraph vs = let ns = zip [0..] vs in mkGraph ns (mkEdges ns) | |
mkEdges :: [ENode] -> [EEdge] | |
mkEdges [] = [] | |
mkEdges (n:ns) = (mkEdges' n ns) ++ mkEdges ns | |
mkEdges' :: ENode -> [ENode] -> [EEdge] | |
mkEdges' n = map $ mkEdge n | |
mkEdge :: ENode -> ENode -> EEdge | |
mkEdge (n, (x, y)) (n', (x', y')) = let dx = fromIntegral (x - x') | |
dy = fromIntegral (y - y') | |
in (n, n', sqrt $ dx ** 2 + dy ** 2) | |
-- SVG | |
type Pen = (String, Int) | |
svg :: Int -> Int -> [(ENode, Pen)] -> [(Edge, Pen)] -> String | |
svg w h ns es = header ++ edges ++ nodes ++ footer | |
where | |
lns = map fst ns | |
header = printf "<svg xml:space=\"default\" width=\"%d\" height=\"%d\">" w h | |
node ((_, (x, y)), (c, s)) = printf "<circle cx=\"%d\" cy=\"%d\" r=\"5\" fill=\"white\" stroke=\"%s\" stroke-width=\"%d\" />" x y c s | |
nodes = concatMap node ns | |
edge ((n, n'), b) = edge' b (fromJust $ lookup n lns) (fromJust $ lookup n' lns) | |
edge' (c, s) (x, y) (x', y') = printf "<line x1=\"%d\" y1=\"%d\" x2=\"%d\" y2=\"%d\" stroke=\"%s\" stroke-width=\"%d\" />" x y x' y' c s | |
edges = concatMap edge es | |
footer = "</svg>" | |
main = do | |
let w = 1000; h = 1000 | |
g <- genEGraph 100 (0, w) (0, h) | |
let nb = ("black", 3) | |
eb = ("green", 1) | |
heb = ("blue", 3) | |
ns = labNodes g | |
es = edges g | |
sg = msGraph g | |
hp = hamiltonPath sg | |
hes = pathEdges hp | |
cns = zip ns (repeat nb) | |
ces = zip (es \\ hes) (repeat eb) | |
ches = zip hes (repeat heb) | |
putStrLn $ svg w h cns (ces ++ ches) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment