module Render (
renderTurnToFile
) where
import Diplomacy
import Conf
import Graphics.Rendering.Cairo
type Color = (Double, Double, Double)
setSourceRGBt :: Color -> Render ()
setSourceRGBt (r, g, b) = setSourceRGB r g b
strokeWith :: Render a -> Render ()
strokeWith r = newPath >> r >> stroke
moveToV :: (Double, Double) -> Render ()
moveToV = uncurry moveTo
lineToV :: (Double, Double) -> Render ()
lineToV = uncurry lineTo
circleV :: (Double, Double) -> Double -> Render ()
circleV pt rad = (uncurry arc) pt rad 0 (2*pi)
shade :: t -> (t, t, t)
shade x = (x,x,x)
white :: (Num t) => (t, t, t)
white = shade 1
gray :: (Fractional t) => (t, t, t)
gray = shade 0.8
black :: (Num t) => (t, t, t)
black = shade 0
data PowerProperties = PowerProperties {
pPowerColor :: Color, pPowerText :: Color, pPowerBorder :: Color,
pPowerLetter :: String
}
props :: Power -> PowerProperties
props Austria = PowerProperties (1,0,0) white black "A"
props England = PowerProperties (0,0,1) white black "E"
props France = PowerProperties (0,1,1) black black "F"
props Germany = PowerProperties (0,0,0) white gray "G"
props Italy = PowerProperties (0,1,0) black black "I"
props Russia = PowerProperties (1,1,1) black black "R"
props Turkey = PowerProperties (1,1,0) black black "T"
powerColor :: Power -> Color
powerColor = pPowerColor . props
powerBorder :: Power -> Color
powerBorder = pPowerBorder . props
renderTitle :: String -> Render ()
renderTitle title = do
selectFontFace "Times New Roman" FontSlantNormal FontWeightNormal
setFontSize 100
setSourceRGBt black
moveTo 10 100
showText title
renderUnit :: Power -> Unit -> Render ()
renderUnit power units = rUnit units where
rUnit unts = do
setSourceRGBt (powerColor power); rShape unts; fill
setSourceRGBt (powerBorder power); rShape unts; stroke
rShape Army = circleV (0, 0) armyRadius
rShape Fleet = rectangle (w/2) (h/2) w h where (w, h) = fleetDimensions
armyRadius = 10
fleetDimensions = (40, 20)
renderUnits :: Conf -> Power -> [(Unit, Location)] -> Render ()
renderUnits conf power unitpos = do
mapM_ tRenderUnitPos unitpos
where
tRenderUnitPos (unit, position) = do
save; uncurry translate (locXY conf position);
renderUnit power unit; restore
type XY = (Double, Double)
vlen :: (Floating t) => (t, t) -> t
vlen (vx, vy) = sqrt (vx**2 + vy**2)
norm :: (Floating t) => (t, t) -> (t, t)
norm v@(vx, vy) = (vx/l, vy/l) where l = vlen v
vleft :: (Num a) => (t, a) -> (a, t)
vleft (vx, vy) = (vy, vx)
vright :: (Num a) => (a, t) -> (t, a)
vright (vx, vy) = (vy, vx)
(+.) :: (Num t1, Num t) => (t, t1) -> (t, t1) -> (t, t1)
(ax, ay) +. (bx, by) = (ax+bx, ay+by)
(-.) :: (Num t1, Num t) => (t, t1) -> (t, t1) -> (t, t1)
(ax, ay) -. (bx, by) = (axbx, ayby)
(*.) :: (Num a) => a -> (a, a) -> (a, a)
a *. (bx, by) = (a*bx, a*by)
drawArrow :: Bool -> XY -> XY -> Render ()
drawArrow failure src dst = do
let vec = dst -. src
let forward = norm vec
let left = vleft forward
let right = vright forward
let tal = src +. (12 *. forward)
let tip = dst -. (shyFraction *. vec)
let neck = tip -. (headLength *. forward)
let arrowshape = do
newPath
moveToV $ tal +. (tailSize *. left)
lineToV $ tal +. ((tailSize/2) *. forward)
lineToV $ tal +. (tailSize *. right)
lineToV $ neck +. (neckWidth *. right)
lineToV $ neck +. (headWidth *. right) +. ((2) *. forward)
lineToV $ tip
lineToV $ neck +. (headWidth *. left) +. ((2) *. forward)
lineToV $ neck +. (neckWidth *. left)
closePath
if failure then do
setSourceRGBt gray; arrowshape; fill
setSourceRGBt black; arrowshape; stroke
else do
setSourceRGBt black; arrowshape; fill
setSourceRGBt gray; arrowshape; stroke
where
shyFraction = 0.08
headLength = 15
headWidth = 10
neckWidth = 2
tailSize = 5
supportPoint :: Conf -> UnitMove -> XY
supportPoint conf (UnitMove (_, source) move) = s move where
s Hold = locXY conf source
s (Attack target) = (sx + (txsx) / 2, sy + (tysy) / 2) where
(sx,sy) = locXY conf source
(tx,ty) = locXY conf target
renderMoveTry :: Conf -> UnitMoveTry -> Render ()
renderMoveTry conf (UnitMove (_, source) move, failure) = do
setDash (if failure then [8, 4] else []) 0
r move
where
r Hold = return ()
r (Attack target) = drawArrow failure (locXY conf source) (locXY conf target)
r (Support mov) = do let pt = supportPoint conf mov
setSourceRGBt black
strokeWith $ do
moveToV $ locXY conf source
lineToV pt
strokeWith $ circleV pt 5
r (Convoy _) = return ()
renderTurn :: Conf -> Turn -> Render ()
renderTurn conf (Turn name _ units moves _) = do
renderTitle name
mapM_ (uncurry (renderUnits conf)) units
mapM_ (\(_, movs) -> mapM_ (renderMoveTry conf) movs) moves
renderTurnToFile :: Conf -> Turn -> FilePath -> IO ()
renderTurnToFile conf turn outfile = do
withImageSurfaceFromPNG "data/map.png" $ \image -> do
(width, height) <- renderWith image $ do
width <- imageSurfaceGetWidth image
height <- imageSurfaceGetHeight image
return (width, height)
withImageSurface FormatARGB32 width height $ \surface -> do
renderWith surface $ do
renderTurn conf turn
surfaceWriteToPNG surface outfile