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