-- hsdip -- a diplomacy parser/renderer.
-- Copyright (C) 2006 Evan Martin <martine@danga.com>

module Render (
  renderTurnToFile
) where

-- import JudgeParser
import Diplomacy
import Conf
import Graphics.Rendering.Cairo
--import Control.Monad

type Color = (Double, Double, Double)

setSourceRGBt :: Color -> Render ()
setSourceRGBt (r, g, b) = setSourceRGB r g b

-- fillWith :: forall a. Render a -> Render ()
-- fillWith r   = newPath >> r >> fill

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
-- powerText :: Power -> Color
-- powerText   = pPowerText   . props
powerBorder :: Power -> Color
powerBorder = pPowerBorder . props
-- powerLetter :: Power -> String
-- powerLetter = pPowerLetter . props

renderTitle :: String -> Render ()
renderTitle title = do
  selectFontFace "Times New Roman" FontSlantNormal FontWeightNormal
  setFontSize 100
  setSourceRGBt black
  moveTo 10 100
  showText title

-- centerText :: String -> Render ()
-- centerText text = do
--   extents <- textExtents text
--   let centerx = -1 + negate (textExtentsWidth extents / 2.0)
--   let centery = textExtentsHeight extents / 2.0
--   moveTo centerx centery
--   showText text

renderUnit :: Power -> Unit -> Render ()
renderUnit power units = rUnit units {- >> rText -} 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
--   rText = do
--     selectFontFace "Sans" FontSlantNormal FontWeightBold
--     setFontSize fontSize
--     setSourceRGBt (powerText power)
--     centerText (powerLetter power)
--  fontSize :: Int
--  fontSize = 14
  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) = (ax-bx, ay-by)

(*.) :: (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 side = headWidth *. forward
  let neck = tip -. (headLength *. forward)
  let arrowshape = do
        newPath
        -- tail
        moveToV $ tal +. (tailSize *. left)
        lineToV $ tal +. ((tailSize/2) *. forward)
        lineToV $ tal +. (tailSize *. right)
        -- neck
        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  -- amount to shy away from src/target
    headLength = 15 -- length of arrow head
    headWidth = 10  -- width of arrow head
    neckWidth = 2
    tailSize = 5

-- given a move, return the point where the move would be supported.
supportPoint :: Conf -> UnitMove -> XY
supportPoint conf (UnitMove (_, source) move) = s move where
  s Hold            = locXY conf source
  s (Attack target) = (sx + (tx-sx) / 2, sy + (ty-sy) / 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
        --save; setSourceSurface image 0 0; paint; restore
        renderTurn conf turn
      surfaceWriteToPNG surface outfile

-- vim: set ts=2 sw=2 et :