SDLRender.hs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 -- |SDLRender: generic wrapper around sdl-gfx for drawing on hex grids
  12 module SDLRender where
  13
  14 import Graphics.UI.SDL
  15 import Graphics.UI.SDL.Primitives
  16 import qualified Graphics.UI.SDL.TTF as TTF
  17 import Data.Monoid
  18 import Control.Monad
  19 import Control.Monad.IO.Class
  20 import Control.Monad.Trans.Reader
  21 import Control.Monad.Trans.Maybe
  22 import Control.Monad.Trans.Class
  23 import Data.Map (Map)
  24 import qualified Data.Map as Map
  25 import Data.List (maximumBy)
  26 import Data.Function (on)
  27 import GHC.Int (Int16)
  28 import Control.Applicative
  29
  30 import Hex
  31 import Util
  32
  33 -- |SVec: screen vectors, in pixels
  34 data SVec = SVec { cx, cy :: Int }
  35     deriving (Eq, Ord, Show)
  36 instance Monoid SVec where
  37     mempty = SVec 0 0
  38     mappend (SVec x y) (SVec x' y') = SVec (x+x') (y+y')
  39 instance Grp SVec where
  40     neg (SVec x y) = SVec (-x) (-y)
  41 type CCoord = PHS SVec
  42
  43 -- |FVec: floating point screen vectors, multiplied by 'size' to get SVecs.
  44 data FVec = FVec { rcx, rcy :: Float }
  45     deriving (Eq, Ord, Show)
  46 instance Monoid FVec where
  47     mempty = FVec 0 0
  48     mappend (FVec x y) (FVec x' y') = FVec (x+x') (y+y')
  49 instance Grp FVec where
  50     neg (FVec x y) = FVec (-x) (-y)
  51
  52 -- The following leads to overlapping instances (not sure why):
  53 --instance MultAction Float FVec where
  54 --    r *^ FVec x y = FVec (r*x) (r*y)
  55 -- So instead, we define a new operator:
  56 (**^) :: Float -> FVec -> FVec
  57 r **^ FVec x y = FVec (r*x) (r*y)
  58
  59
  60 hexVec2SVec :: Int -> HexVec -> SVec
  61 hexVec2SVec size (HexVec x y z) =
  62     SVec ((x-z) * size) (-y * 3 * ysize size)
  63
  64 hexVec2FVec :: HexVec -> FVec
  65 hexVec2FVec (HexVec x y z) =
  66     FVec (fi $ x-z) (-(fi y) * 3 * ylen)
  67
  68 sVec2dHV :: Int -> SVec -> (Double,Double,Double)
  69 sVec2dHV size (SVec sx sy) =
  70     let sx',sy',size' :: Double
  71         [sx',sy',size',ysize'] = map fi [sx,sy,size,ysize size]
  72         y' = -sy' / ysize' / 3
  73         x' = ((sx' / size') - y') / 2
  74         z' = -((sx' / size') + y') / 2
  75     in (x',y',z')
  76
  77 sVec2HexVec :: Int -> SVec -> HexVec
  78 sVec2HexVec size sv =
  79     let (x',y',z') = sVec2dHV size sv
  80         unrounded = Map.fromList [(1,x'),(2,y'),(3,z')]
  81         rounded = Map.map round unrounded
  82         maxdiff = fst $ maximumBy (compare `on` snd) $
  83             [ (i, abs $ c'-c) | i <- [1..3],
  84                 let c' = unrounded Map.! i, let c = fi $ rounded Map.! i]
  85         [x,y,z] = map snd $ Map.toList $
  86             Map.adjust (\x -> x - (sum $ Map.elems rounded)) maxdiff rounded
  87     in HexVec x y z
  88
  89
  90 data RenderContext = RenderContext
  91     { renderSurf :: Surface
  92     , renderBGSurf :: Maybe Surface
  93     , renderHCentre :: HexPos
  94     , renderSCentre :: SVec
  95     , renderSize :: Int
  96     , renderFont :: Maybe TTF.Font
  97     }
  98 type RenderT = ReaderT RenderContext
  99
 100 runRenderT = runReaderT
 101
 102 displaceRender :: Monad m => FVec -> RenderT m a -> RenderT m a
 103 displaceRender v m = do
 104     size <- asks renderSize
 105     let FVec x y = fi size **^ v
 106     let sv = SVec (round x) (round y)
 107     displaceRenderSVec sv m
 108
 109 displaceRenderSVec :: Monad m => SVec -> RenderT m a -> RenderT m a
 110 displaceRenderSVec sv =
 111     local $ \rc -> rc { renderSCentre = renderSCentre rc +^ sv }
 112
 113 recentreAt :: Monad m => HexVec -> RenderT m a -> RenderT m a
 114 recentreAt v m = do
 115     size <- asks renderSize
 116     displaceRenderSVec (hexVec2SVec size v) m
 117
 118 rescaleRender :: Monad m => RealFrac n => n -> RenderT m a -> RenderT m a
 119 rescaleRender r = local $ \rc -> rc { renderSize = round $ r * (fi $ renderSize rc) }
 120
 121 withFont :: Monad m => Maybe TTF.Font -> RenderT m a -> RenderT m a
 122 withFont font = local $ \rc -> rc { renderFont = font }
 123
 124 renderPos :: Monad m => Integral i => FVec -> RenderT m (i,i)
 125 renderPos v = do
 126     size <- asks renderSize
 127     let FVec dx dy = fi size **^ v
 128     SVec x y <- asks renderSCentre
 129     return $ (fi x + round dx, fi y + round dy)
 130 renderLen :: Monad m => Integral i => Float -> RenderT m i
 131 renderLen l = do
 132     size <- asks renderSize
 133     return $ round $ l * fi size
 134
 135
 136 -- wrappers around sdl-gfx functions
 137 pixelR v col = do
 138     (x,y) <- renderPos v
 139     surf <- asks renderSurf
 140     void.liftIO $ pixel surf x y col
 141
 142 aaLineR v v' col = do
 143     (x,y) <- renderPos v
 144     (x',y') <- renderPos v'
 145     surf <- asks renderSurf
 146     void.liftIO $ aaLine surf x y x' y' col
 147
 148 filledPolygonR verts fillCol = do
 149     ps <- mapM renderPos verts
 150     surf <- asks renderSurf
 151     void.liftIO $ filledPolygon surf ps fillCol
 152
 153 arcR v rad a1 a2 col = do
 154     (x,y) <- renderPos v
 155     r <- renderLen rad
 156     surf <- asks renderSurf
 157     void.liftIO $ arc surf x y r a1 a2 col
 158
 159 filledCircleR v rad col = do
 160     (x,y) <- renderPos v
 161     r <- renderLen rad
 162     surf <- asks renderSurf
 163     void.liftIO $ filledCircle surf x y r col
 164
 165 -- aaPolygon seems to be a bit buggy in sdl-gfx-0.6.0
 166 aaPolygonR verts col =
 167     aaLinesR (verts ++ take 1 verts) col
 168
 169 -- aaCircle too
 170 aaCircleR v rad col = do
 171     (x,y) <- renderPos v
 172     r <- renderLen rad
 173     surf <- asks renderSurf
 174     if (r <= 1) then void.liftIO $ pixel surf x y col
 175     else void.liftIO $ aaCircle surf x y r col
 176
 177
 178 aaLinesR verts col =
 179     sequence_ [ aaLineR v v' col |
 180         (v,v') <- zip (take (length verts - 1) verts) (drop 1 verts) ]
 181
 182 rimmedPolygonR verts fillCol rimCol = do
 183     filledPolygonR verts fillCol
 184     aaPolygonR verts $ opaquify rimCol
 185     return ()
 186
 187 rimmedCircleR v rad fillCol rimCol = void $ do
 188     filledCircleR v rad fillCol
 189     aaCircleR v rad $ opaquify rimCol
 190
 191 thickLineR :: (Functor m, MonadIO m) => FVec -> FVec -> Float -> Pixel -> RenderT m ()
 192 thickLineR from to thickness col =
 193     let FVec dx dy = to -^ from
 194         baseThickness = (1/16)
 195         s = baseThickness * thickness / (sqrt $ dx^2 + dy^2)
 196         perp = (s/2) **^ FVec dy (-dx)
 197     in rimmedPolygonR
 198         [ from +^ perp, to +^ perp
 199         , to +^ neg perp, from +^ neg perp]
 200         (dim col) (bright col)
 201
 202 thickLinesR verts thickness col =
 203     sequence_ [ thickLineR v v' thickness col |
 204         (v,v') <- zip (take (length verts - 1) verts) (drop 1 verts) ]
 205
 206 thickPolygonR verts thickness col =
 207     thickLinesR (verts ++ take 1 verts) thickness col
 208
 209
 210 ylen = 1 / sqrt 3
 211 ysize :: Int -> Int
 212 ysize = (map (\size -> round $ fi size * ylen) [0..] !!)
 213
 214 corner :: Int -> FVec
 215 corner hextant = FVec x y
 216     where
 217         [x,y] = f hextant
 218         f 0 = [1, -ylen]
 219         f 1 = [0, -2*ylen]
 220         f 2 = [-1, -ylen]
 221         f n | n < 6 = let [x,y] = f (5-n) in [x,-y]
 222             | n < 0 = f (6-n)
 223             | otherwise = f (n`mod`6)
 224
 225 innerCorner :: HexDir -> FVec
 226 innerCorner dir = FVec x y
 227     where
 228         [x,y] = f dir
 229         f dir
 230             | dir == hu = [2/3, 0]
 231             | dir == hv = [-1/3, -ylen]
 232             | dir == hw = [-1/3, ylen]
 233             | not (isHexDir dir) = error "innerCorner: not a hexdir"
 234             | otherwise = map (\z -> -z) $ f $ neg dir
 235
 236 edge :: HexDir -> FVec
 237 edge dir = FVec x y
 238     where
 239         [x,y] = f dir
 240         f dir
 241             | dir == hu = [1, 0]
 242             | dir == hv = [-1/2, -3*ylen/2]
 243             | dir == hw = [-1/2, 3*ylen/2]
 244             | not (isHexDir dir) = error "edge: not a hexdir"
 245             | otherwise = map (\z -> -z) $ f $ neg dir
 246
 247
 248 black = Pixel 0x01000000
 249 white = Pixel 0xffffff00
 250 orange = Pixel 0xff7f0000
 251
 252 colourWheel :: Int -> Pixel
 253 colourWheel n = Pixel $ (((((r * 0x100) + g) * 0x100) + b) * 0x100) + a
 254     where [r,g,b] = map (\on -> if on then 0xff else 0) $ colourWheel' n
 255           a = 0x00
 256           colourWheel' 0 = [True, False, False]
 257           colourWheel' 1 = [True, True, False]
 258           colourWheel' n = let [a,b,c] = colourWheel' $ n-2 in [c,a,b]
 259
 260 red = colourWheel 0
 261 yellow = colourWheel 1
 262 green = colourWheel 2
 263 cyan = colourWheel 3
 264 blue = colourWheel 4
 265 purple = colourWheel 5
 266
 267 colourOf :: Ord i => Map i Int -> i -> Pixel
 268 colourOf colouring idx =
 269     case Map.lookup idx colouring of
 270             Nothing -> white
 271             Just n -> colourWheel n
 272
 273 setPixelAlpha alpha (Pixel v) = Pixel $ v `div` 0x100 * 0x100 + alpha
 274 bright = setPixelAlpha 0xff
 275 brightish = setPixelAlpha 0xc0
 276 dim = setPixelAlpha 0xa0
 277 obscure = setPixelAlpha 0x80
 278 faint = setPixelAlpha 0x40
 279 invisible = setPixelAlpha 0x00
 280
 281 pixelToRGBA (Pixel v) =
 282     let (r,v') = divMod v 0x1000000
 283         (g,v'') = divMod v' 0x10000
 284         (b,a) = divMod v'' 0x100
 285     in (r,g,b,a)
 286 rgbaToPixel (r,g,b,a) = Pixel $ a+0x100*(b+0x100*(g+0x100*r))
 287 opaquify p =
 288     let (r,g,b,a) = pixelToRGBA p
 289         [r',g',b'] = map (\v -> (v*a)`div`0xff) [r,g,b]
 290     in rgbaToPixel (r',g',b',0xff)
 291
 292 messageCol = white
 293 dimWhiteCol = Pixel 0xa0a0a000
 294 buttonTextCol = white
 295 errorCol = red
 296
 297
 298 pixelToColor p =
 299     let (r,g,b,_) = pixelToRGBA p
 300     in Color (fi r) (fi g) (fi b)
 301
 302 renderStrColAt,renderStrColAtLeft :: (Functor m, MonadIO m) => Pixel -> String -> HexVec -> RenderT m ()
 303 renderStrColAt = renderStrColAt' True
 304 renderStrColAtLeft = renderStrColAt' False
 305 renderStrColAt' :: (Functor m, MonadIO m) => Bool -> Pixel -> String -> HexVec -> RenderT m ()
 306 renderStrColAt' centred c str v = void $ runMaybeT $ do
 307     font <- MaybeT $ asks renderFont
 308     fsurf <- MaybeT $ liftIO $ TTF.tryRenderTextBlended font str $ pixelToColor c
 309     (surf, scrCentre, size) <- lift $ asks $ liftM3 (,,) renderSurf renderSCentre renderSize
 310     let SVec x y = scrCentre +^ (hexVec2SVec size v)
 311             +^ neg (SVec 0 ((surfaceGetHeight fsurf-1)`div`2) +^
 312                 if centred
 313                     then SVec ((surfaceGetWidth fsurf)`div`2) 0
 314                     else SVec 0 0)
 315     void $ liftIO $ blitSurface fsurf Nothing surf (Just $ Rect x y 0 0)
 316
 317 renderStrColAbove,renderStrColBelow :: (Functor m, MonadIO m) => Pixel -> String -> HexVec -> RenderT m ()
 318 renderStrColAbove = renderStrColVShifted True
 319 renderStrColBelow = renderStrColVShifted False
 320 renderStrColVShifted :: (Functor m, MonadIO m) => Bool -> Pixel -> String -> HexVec -> RenderT m ()
 321 renderStrColVShifted up c str v =
 322     displaceRender (FVec 1 0) $ renderStrColAt c str $ v +^ (if up then hv else hw)
 323
 324 erase :: (Functor m, MonadIO m) => RenderT m ()
 325 erase = fillRectBG Nothing
 326
 327 fillRectBG :: (Functor m, MonadIO m) => Maybe Rect -> RenderT m ()
 328 fillRectBG mrect = do
 329     surf <- asks renderSurf
 330     mbgsurf <- asks renderBGSurf
 331     void $ liftIO $ maybe
 332         (fillRect surf mrect black)
 333         (\bgsurf -> blitSurface bgsurf mrect surf mrect)
 334         mbgsurf
 335
 336 blankRow v = do
 337     (surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize
 338     let SVec _ y = scrCentre +^ (hexVec2SVec size v)
 339         w = surfaceGetWidth surf
 340         h = ceiling $ fi (size * 3 `div` 2) * 2 / sqrt 3
 341     fillRectBG $ Just $ Rect 0 (y-h`div`2) w h
 342
 343 blitAt :: (Functor m, MonadIO m) => Surface -> HexVec -> RenderT m ()
 344 blitAt surface v = do
 345     (surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize
 346     let SVec x y = scrCentre +^ (hexVec2SVec size v)
 347         w = surfaceGetWidth surface
 348         h = surfaceGetHeight surface
 349     void $ liftIO $ blitSurface surface Nothing surf $ Just $
 350         Rect (x-w`div`2) (y-h`div`2) (w+1) (h+1)