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