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             | dir == zero = [0,0]
 234             | not (isHexDir dir) = error "innerCorner: not a hexdir"
 235             | otherwise = map (\z -> -z) $ f $ neg dir
 236
 237 edge :: HexDir -> FVec
 238 edge dir = FVec x y
 239     where
 240         [x,y] = f dir
 241         f dir
 242             | dir == hu = [1, 0]
 243             | dir == hv = [-1/2, -3*ylen/2]
 244             | dir == hw = [-1/2, 3*ylen/2]
 245             | not (isHexDir dir) = error "edge: not a hexdir"
 246             | otherwise = map (\z -> -z) $ f $ neg dir
 247
 248 rotFVec :: Float -> FVec -> FVec -> FVec
 249 rotFVec th (FVec cx cy) v@(FVec x y)
 250     | th == 0 = v
 251     | otherwise = FVec (cx + c*dx-s*dy) (cy + s*dx+c*dy)
 252     where
 253         dx = x-cx
 254         dy = y-cy
 255         c = cos th
 256         s = sin th
 257
 258 black = Pixel 0x01000000
 259 white = Pixel 0xffffff00
 260 orange = Pixel 0xff7f0000
 261
 262 colourWheel :: Int -> Pixel
 263 colourWheel n = Pixel $ (((((r * 0x100) + g) * 0x100) + b) * 0x100) + a
 264     where [r,g,b] = map (\on -> if on then 0xff else 0) $ colourWheel' n
 265           a = 0x00
 266           colourWheel' 0 = [True, False, False]
 267           colourWheel' 1 = [True, True, False]
 268           colourWheel' n = let [a,b,c] = colourWheel' $ n-2 in [c,a,b]
 269
 270 red = colourWheel 0
 271 yellow = colourWheel 1
 272 green = colourWheel 2
 273 cyan = colourWheel 3
 274 blue = colourWheel 4
 275 purple = colourWheel 5
 276
 277 colourOf :: Ord i => Map i Int -> i -> Pixel
 278 colourOf colouring idx =
 279     case Map.lookup idx colouring of
 280             Nothing -> white
 281             Just n -> colourWheel n
 282
 283 setPixelAlpha alpha (Pixel v) = Pixel $ v `div` 0x100 * 0x100 + alpha
 284 bright = setPixelAlpha 0xff
 285 brightish = setPixelAlpha 0xc0
 286 dim = setPixelAlpha 0xa0
 287 obscure = setPixelAlpha 0x80
 288 faint = setPixelAlpha 0x40
 289 invisible = setPixelAlpha 0x00
 290
 291 pixelToRGBA (Pixel v) =
 292     let (r,v') = divMod v 0x1000000
 293         (g,v'') = divMod v' 0x10000
 294         (b,a) = divMod v'' 0x100
 295     in (r,g,b,a)
 296 rgbaToPixel (r,g,b,a) = Pixel $ a+0x100*(b+0x100*(g+0x100*r))
 297 opaquify p =
 298     let (r,g,b,a) = pixelToRGBA p
 299         [r',g',b'] = map (\v -> (v*a)`div`0xff) [r,g,b]
 300     in rgbaToPixel (r',g',b',0xff)
 301
 302 messageCol = white
 303 dimWhiteCol = Pixel 0xa0a0a000
 304 buttonTextCol = white
 305 errorCol = red
 306
 307
 308 pixelToColor p =
 309     let (r,g,b,_) = pixelToRGBA p
 310     in Color (fi r) (fi g) (fi b)
 311
 312 renderStrColAt,renderStrColAtLeft :: (Functor m, MonadIO m) => Pixel -> String -> HexVec -> RenderT m ()
 313 renderStrColAt = renderStrColAt' True
 314 renderStrColAtLeft = renderStrColAt' False
 315 renderStrColAt' :: (Functor m, MonadIO m) => Bool -> Pixel -> String -> HexVec -> RenderT m ()
 316 renderStrColAt' centred c str v = void $ runMaybeT $ do
 317     font <- MaybeT $ asks renderFont
 318     fsurf <- MaybeT $ liftIO $ TTF.tryRenderTextBlended font str $ pixelToColor c
 319     (surf, scrCentre, size) <- lift $ asks $ liftM3 (,,) renderSurf renderSCentre renderSize
 320     let SVec x y = scrCentre +^ (hexVec2SVec size v)
 321             +^ neg (SVec 0 ((surfaceGetHeight fsurf-1)`div`2) +^
 322                 if centred
 323                     then SVec ((surfaceGetWidth fsurf)`div`2) 0
 324                     else SVec 0 0)
 325     void $ liftIO $ blitSurface fsurf Nothing surf (Just $ Rect x y 0 0)
 326
 327 renderStrColAbove,renderStrColBelow :: (Functor m, MonadIO m) => Pixel -> String -> HexVec -> RenderT m ()
 328 renderStrColAbove = renderStrColVShifted True
 329 renderStrColBelow = renderStrColVShifted False
 330 renderStrColVShifted :: (Functor m, MonadIO m) => Bool -> Pixel -> String -> HexVec -> RenderT m ()
 331 renderStrColVShifted up c str v =
 332     displaceRender (FVec 1 0) $ renderStrColAt c str $ v +^ (if up then hv else hw)
 333
 334 erase :: (Functor m, MonadIO m) => RenderT m ()
 335 erase = fillRectBG Nothing
 336
 337 fillRectBG :: (Functor m, MonadIO m) => Maybe Rect -> RenderT m ()
 338 fillRectBG mrect = do
 339     surf <- asks renderSurf
 340     mbgsurf <- asks renderBGSurf
 341     void $ liftIO $ maybe
 342         (fillRect surf mrect black)
 343         (\bgsurf -> blitSurface bgsurf mrect surf mrect)
 344         mbgsurf
 345
 346 blankRow v = do
 347     (surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize
 348     let SVec _ y = scrCentre +^ (hexVec2SVec size v)
 349         w = surfaceGetWidth surf
 350         h = ceiling $ fi (size * 3 `div` 2) * 2 / sqrt 3
 351     fillRectBG $ Just $ Rect 0 (y-h`div`2) w h
 352
 353 blitAt :: (Functor m, MonadIO m) => Surface -> HexVec -> RenderT m ()
 354 blitAt surface v = do
 355     (surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize
 356     let SVec x y = scrCentre +^ (hexVec2SVec size v)
 357         w = surfaceGetWidth surface
 358         h = surfaceGetHeight surface
 359     void $ liftIO $ blitSurface surface Nothing surf $ Just $
 360         Rect (x-w`div`2) (y-h`div`2) (w+1) (h+1)