wuerfelschlange-0.1: src/Graph.hs

module Main where

import Text.Printf (printf)

import qualified Data.Map as Map
import Data.Map (Map)


type Node = (Int, Int)

pattern :: Node -> [Bool]
pattern (a,b) = map (flip elem [a,b]) [0..5]

ident, label :: Node -> String
ident (a,b) =
   map (\x -> if x then 'A' else '_') $ pattern (a,b)

label (a,b) =
   map (\x -> if x then ':' else '.') $ pattern (a,b)

move :: [((Node, Node), String)]
move =
   (((0,0), (0,0)), "loop above") :
   [(((a,b),(a-1,b-1)), "") | a<-[1..5], b<-[a..5]]

roll :: [((Node, Node), String)]
roll =
   [(((0,1),(0,0)), "")]
   ++
   [(((0,1),(0,1)), "loop above")]
   ++
   [(((0,1),(0,a)), "out=-80,in=170") | a<-[2..5]]
   ++
   [((from,to), Map.findWithDefault "" (from,to) arcs) |
       b<-[2..5], let b' = pred b, a<-[0..5],
       let from = (0,b); to = (min a b', max a b')]

arcs :: Map (Node, Node) String
arcs =
   Map.fromList $
      (((0,2),(1,3)), "out=-10,in=-170") :
      (((0,3),(2,3)), "out=45,in=-80") :
      (((0,3),(2,5)), "out=-20,in=-160") :
      (((0,4),(3,4)), "out=45,in=-80") :
      (((0,5),(3,4)), "out=90,in=-80") :
      (((0,5),(4,5)), "out=45,in=-80") :
      []

edge1 ::  ((Node, Node), String) -> String
edge1 (((a,b),(c,d)), option) =
   printf "(%s) edge [%s,dashed] (%s)" (ident (a,b)) option (ident (c,d))

edge2 :: ((Node, Node), String) -> String
edge2 (((a,b),(c,d)), option) =
   printf "(%s) edge [%s] (%s)" (ident (a,b)) option (ident (c,d))

pos :: Node -> String
pos (a,b) =
   printf "\\node[state%s] (%s) [at={(%d/2+%d*2,1.5*(%d-%d))}] {%s};"
      (if a==0 && b/=0 then ",rolling" else "")
      (ident (a,b)) a b a b (label (a,b))

posCircularSector :: Node -> String
posCircularSector p@(0,0) =
   printf "\\node[state] (%s) [at={(0,0)}] {%s};" (ident p) (label p)
posCircularSector (a,b) =
   let af = fromIntegral a
       bf = fromIntegral b
       cos90, sin90 :: Float -> Float
       cos90 x = cos (x/180*pi)
       sin90 x = sin (x/180*pi)
   in printf "\\node[state] (%s) [at={(%f,%f)}] {%s};"
         (ident (a,b))
         (2*bf*cos90(60/bf*(af-bf)))
         (2*bf*sin90(60/bf*(af-bf)))
         (label (a,b))

allNodes :: [Node]
allNodes = [(a,b) | a<-[0..5],b<-[a..5]]

graph :: String
graph =
   unlines $
      "\\begin{tikzpicture}[auto,rolling/.style=double]" :
      map pos allNodes ++
      "\\path[->]" :
      map edge1 move ++ map edge2 roll ++
      ";" :
      "\\end{tikzpicture}" :
      []

main :: IO ()
main = putStr graph