SDLGlyph.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 module SDLGlyph where
  12
  13 import Graphics.UI.SDL
  14 import Control.Monad
  15 import Control.Monad.IO.Class
  16 import Control.Monad.Trans.State
  17 import Control.Monad.Trans.Reader
  18 import Control.Monad.Trans.Maybe
  19 import Control.Monad.Trans.Class
  20 import Data.Map (Map)
  21 import qualified Data.Map as Map
  22 import qualified Data.List as List
  23 import Control.Applicative
  24 import System.Random (randomRIO)
  25
  26 import Hex
  27 import SDLRender
  28 import GameState
  29 import GameStateTypes
  30 import BoardColouring
  31 import Physics
  32 import Command
  33 import Util
  34
  35
  36 data ShowBlocks = ShowBlocksBlocking | ShowBlocksAll | ShowBlocksNone
  37     deriving (Eq, Ord, Show, Read)
  38
  39 data Glyph
  40     = TileGlyph Tile Pixel
  41     | SpringGlyph HexDir HexDir SpringExtension HexDir Pixel
  42     | PivotGlyph TorqueDir HexDir Pixel
  43     | ArmGlyph TorqueDir HexDir Pixel
  44     | BlockedArm HexDir TorqueDir Pixel
  45     | TurnedArm HexDir TorqueDir Pixel
  46     | BlockedBlock Tile HexDir Pixel
  47     | BlockedPush HexDir Pixel
  48     | CollisionMarker
  49     | HollowGlyph Pixel
  50     | HollowInnerGlyph Pixel
  51     | FilledHexGlyph Pixel
  52     | ButtonGlyph Pixel
  53     | UseFiveColourButton Bool
  54     | ShowBlocksButton ShowBlocks
  55     | ShowButtonTextButton Bool
  56     | UseSoundsButton Bool
  57     | WhsButtonsButton (Maybe WrHoSel)
  58     | FullscreenButton Bool
  59     | DisplacedGlyph HexDir Glyph
  60     | UnfreshGlyph
  61     deriving (Eq, Ord, Show)
  62
  63 type SizedGlyph = (Glyph,Int)
  64 data CachedGlyphs = CachedGlyphs (Map SizedGlyph Surface) [SizedGlyph]
  65     deriving (Eq, Ord, Show)
  66 emptyCachedGlyphs = CachedGlyphs Map.empty []
  67 maxCachedGlyphs = 100
  68
  69 type RenderM = RenderT (StateT CachedGlyphs IO)
  70 runRenderM :: RenderM a -> CachedGlyphs -> RenderContext -> IO (a,CachedGlyphs)
  71 runRenderM m cgs rc = runStateT (runReaderT m rc) cgs
  72
  73 drawAt :: Glyph -> HexPos -> RenderM ()
  74 drawAt gl pos = do
  75         centre <- asks renderHCentre
  76         drawAtRel gl (pos -^ centre)
  77
  78 drawAtRel :: Glyph -> HexVec -> RenderM ()
  79 drawAtRel gl v = do
  80     size <- asks renderSize
  81     displaceRenderSVec (hexVec2SVec size v) $ renderGlyphCaching gl
  82
  83 renderGlyphCaching :: Glyph -> RenderM ()
  84 -- Glyph caching:
  85 --  We aim to cache glyphs which are "currently" being regularly drawn, so
  86 --  they can be blitted from RAM rather than being drawn afresh each time.
  87 --  Rather than track statistics, we adopt the following probabilistic scheme.
  88 renderGlyphCaching gl = do
  89     CachedGlyphs cmap clist <- lift get
  90     size <- asks renderSize
  91     let sgl = (gl,size)
  92         w = size*2 + 1
  93         h = ysize size*4 + 1
  94         newGlyphSurf = do
  95             -- csurf <- liftIO $ createRGBSurface [] w h 32 0xff000000 0x00ff0000 0x0000ff00 0x000000ff
  96             csurf <- liftIO $ createRGBSurface [] w h 16 0 0 0 0
  97             liftIO $ setColorKey csurf [SrcColorKey,RLEAccel] $ Pixel 0
  98             return csurf
  99         renderOnCache csurf =
 100             let ccxt rc = rc { renderSurf = csurf, renderSCentre = SVec (w`div`2) (h`div`2) }
 101             in local ccxt $ renderGlyph gl
 102         addToCache cacheFull csurf = do
 103             CachedGlyphs cmap clist <- lift get
 104             let cmap' = Map.insert sgl csurf cmap
 105             lift $ put $ if cacheFull
 106                 then CachedGlyphs (Map.delete (last clist) cmap') (sgl:List.init clist)
 107                 else CachedGlyphs cmap' (sgl:clist)
 108         promote = do
 109             CachedGlyphs cmap clist <- lift get
 110             lift $ put $ CachedGlyphs cmap (sgl:List.delete sgl clist)
 111         blitGlyph csurf = do
 112             surf <- asks renderSurf
 113             (x,y) <- renderPos zero
 114             void $ liftIO $ blitSurface csurf Nothing surf $ Just $
 115                 Rect (x-w`div`2) (y-h`div`2) (w+1) (h+1)
 116     let cacheFull = Map.size cmap >= maxCachedGlyphs
 117     let mcsurf = Map.lookup sgl cmap
 118     -- with probability 1 in (maxCachedGlyphs`div`2), we put this glyph at the
 119     -- head of the cached list, throwing away the tail to make room if needed.
 120     cacheIt <- (((cacheable &&) . (not cacheFull ||)) <$>) $
 121         liftIO $ (==0) <$> randomRIO (0::Int,maxCachedGlyphs`div`2)
 122     case mcsurf of
 123         Nothing -> if cacheIt
 124             then do
 125                 csurf <- newGlyphSurf
 126                 renderOnCache csurf
 127                 addToCache cacheFull csurf
 128                 blitGlyph csurf
 129             else
 130                 renderGlyph gl
 131         Just csurf -> do
 132             when cacheIt promote
 133             blitGlyph csurf
 134     where
 135         cacheable = case gl of
 136             -- some glyphs need to be drawn with blending - those involving
 137             -- anti-aliasing which bleed over the edge of the hex or which
 138             -- may be drawn on top of an existing glyph.
 139             -- TODO: we should find a way to deal with at least some of these;
 140             -- springs in particular are common and expensive to draw.
 141             -- Maybe we could truncate the spring glyphs to a hex?
 142             TileGlyph (BlockTile adjs) _ -> null adjs
 143             TileGlyph (SpringTile extn dir) _ -> False
 144             SpringGlyph _ _ _ _ _ -> False
 145             FilledHexGlyph _ -> False
 146             HollowGlyph _ -> False
 147             BlockedBlock _ _ _ -> False
 148             BlockedPush _ _ -> False
 149             CollisionMarker -> False
 150             DisplacedGlyph _ _ -> False
 151             _ -> True
 152
 153 renderGlyph :: Glyph -> RenderM ()
 154 renderGlyph (TileGlyph (BlockTile adjs) col) =
 155     rimmedPolygonR corners col $ bright col
 156         where
 157             corners = concat [
 158                 if or $ map adjAt [0,1]
 159                 then [corner $ hextant dir]
 160                 else if adjAt $ -1
 161                     then []
 162                     else [innerCorner dir]
 163                 | dir <- hexDirs
 164                 , let adjAt r = rotate r dir `elem` adjs
 165                 ]
 166
 167 renderGlyph (TileGlyph (SpringTile extn dir) col) =
 168     renderGlyph $ SpringGlyph zero zero extn dir col
 169
 170 renderGlyph (TileGlyph (PivotTile dir) col) = do
 171     renderGlyph $ PivotGlyph 0 dir col
 172
 173 renderGlyph (TileGlyph (ArmTile dir _) col) =
 174     renderGlyph $ ArmGlyph 0 dir col
 175
 176 renderGlyph (TileGlyph HookTile col) =
 177     rimmedCircleR zero (7/8) col $ bright col
 178
 179 renderGlyph (TileGlyph (WrenchTile mom) col) = do
 180     rimmedCircleR zero (1/3) col $ bright col
 181     when (mom /= zero) $
 182         let
 183             from = innerCorner $ neg mom
 184             to = edge $ neg mom
 185             shifts = [ (1/2) **^ (b -^ a)
 186                 | rot <- [-1,0,1]
 187                 , let a = innerCorner $ neg mom
 188                 , let b = innerCorner $ rotate rot $ neg mom
 189                 ]
 190         in sequence_
 191             [ aaLineR (from+^shift) (to+^shift) $ col
 192             | shift <- shifts ]
 193
 194 renderGlyph (TileGlyph BallTile col) =
 195     rimmedCircleR zero (7/8) (faint col) (obscure col)
 196
 197 renderGlyph (SpringGlyph rootDisp endDisp extn dir col) =
 198     thickLinesR points 1 $ brightness col
 199         where
 200             n :: Int
 201             n = 3*case extn of
 202                 Stretched -> 1
 203                 Relaxed -> 2
 204                 Compressed -> 4
 205             brightness = if extn == Relaxed then dim else bright
 206             dir' = if dir == zero then hu else dir
 207             s = corner (hextant dir' - 1) +^ innerCorner endDisp
 208             off = corner (hextant dir') +^ innerCorner endDisp
 209             e = corner (hextant dir' - 3) +^ innerCorner rootDisp
 210             points = [ b +^ (fi i / fi n) **^ (e -^ s)
 211                 | i <- [0..n]
 212                 , i`mod`3 /= 1
 213                 , let b = if i`mod`3==0 then s else off ]
 214
 215 renderGlyph (PivotGlyph rot dir col) = do
 216     rimmedCircleR zero (7/8) col $ bright col
 217     when (dir /= zero)
 218         $ aaLineR from to $ bright col
 219     return ()
 220         where
 221             from = rotFVec th c $ (7/8) **^ edge (neg dir)
 222             to = rotFVec th c $ (7/8) **^ edge dir
 223             c = FVec 0 0
 224             th = - fi rot * pi / 12
 225
 226 renderGlyph (ArmGlyph rot dir col) =
 227     thickLineR from to 1 col
 228         where
 229             dir' = if dir == zero then hu else dir
 230             from = rotFVec th c $ edge $ neg dir'
 231             to = rotFVec th c $ innerCorner dir'
 232             c = (2 **^ edge (neg dir'))
 233             th = - fi rot * pi / 12
 234
 235 renderGlyph (BlockedArm armdir tdir col) =
 236     aaLineR from to col
 237         where
 238             from = innerCorner $ rotate (2*tdir) armdir
 239             to = edge $ rotate tdir armdir
 240
 241 renderGlyph (TurnedArm armdir tdir col) =
 242     sequence_ [ arcR c r a1 a2 col | r <- [8/4,9/4] ]
 243     where
 244         c = hexVec2FVec $ neg armdir
 245         a0 = fi $ -60*hextant armdir
 246         a1' = a0 + fi tdir * 10
 247         a2' = a0 + fi tdir * 30
 248         a1 = min a1' a2'
 249         a2 = max a1' a2'
 250
 251 renderGlyph (BlockedBlock tile dir col) =
 252     displaceRender shift $ renderGlyph (TileGlyph tile col)
 253         where shift = innerCorner dir -^ edge dir
 254
 255 renderGlyph (BlockedPush dir col) = do
 256     thickLineR zero tip 1 col
 257     thickLineR tip (arms!!0) 1 col
 258     thickLineR tip (arms!!1) 1 col
 259     where
 260         tip@(FVec tx ty) = edge dir
 261         arms = [ FVec ((tx/2) + d*ty/4) (ty/2 - d*tx/4) | d <- [-1,1] ]
 262
 263 renderGlyph CollisionMarker = do
 264     -- rimmedCircle surf centre (size`div`3) (bright purple) $ bright purple
 265     aaLineR start end $ col
 266     aaCircleR zero rad col
 267     where
 268         [start,end] = map (((1/2)**^) . corner) [0,3]
 269         rad = ylen
 270         col = dim purple
 271
 272 renderGlyph (HollowGlyph col) =
 273     aaPolygonR corners $ opaquify col
 274     where corners = map corner [0..5]
 275 renderGlyph (HollowInnerGlyph col) =
 276     aaPolygonR corners $ opaquify col
 277     where corners = map innerCorner hexDirs
 278
 279 renderGlyph (FilledHexGlyph col) =
 280     rimmedPolygonR corners col $ brightish col
 281     where corners = map corner [0..5]
 282
 283 renderGlyph (ButtonGlyph col) =
 284     renderGlyph (TileGlyph (BlockTile []) col)
 285
 286 renderGlyph (UseFiveColourButton using) =
 287     rescaleRender (1/2) $ sequence_ [
 288         displaceRender (corner h) $ renderGlyph
 289             (TileGlyph (BlockTile [])
 290                 (dim $ colourWheel (if using then h`div`2 else 1)))
 291         | h <- [0,2,4] ]
 292
 293 renderGlyph (ShowBlocksButton showing) = do
 294     renderGlyph (TileGlyph (BlockTile []) (dim red))
 295     when (showing == ShowBlocksAll) $
 296         renderGlyph (BlockedPush hu (bright orange))
 297     when (showing /= ShowBlocksNone) $
 298         renderGlyph (BlockedPush hw (bright purple))
 299
 300 renderGlyph (ShowButtonTextButton showing) = do
 301     rescaleRender (1/2) $ displaceRender (edge (neg hu)) $
 302         renderGlyph (ButtonGlyph (dim yellow))
 303     when showing $
 304         sequence_ [ pixelR (FVec (1/3 + i/4) (-1/4)) (bright white) | i <- [-1..1] ]
 305
 306 renderGlyph (UseSoundsButton use) = do
 307     sequence [ arcR (FVec (-2/3) 0) r (-20) 20
 308             (if use then bright green else dim red)
 309         | r <- [1/3,2/3,1] ]
 310     when (not use) $
 311         aaLineR (innerCorner hw) (innerCorner $ neg hw) $ dim red
 312
 313 renderGlyph (WhsButtonsButton Nothing) = rescaleRender (1/3) $ do
 314     renderGlyph (ButtonGlyph (dim red))
 315     sequence_ [ displaceRender ((3/2) **^ edge dir) $
 316             renderGlyph (ButtonGlyph (dim purple))
 317         | dir <- hexDirs ]
 318 renderGlyph (WhsButtonsButton (Just whs)) = rescaleRender (1/2) $ do
 319     when (whs /= WHSHook) $
 320         displaceRender (corner 0) $ renderGlyph (TileGlyph (WrenchTile zero) col)
 321     when (whs /= WHSWrench) $ do
 322         displaceRender (corner 4) $ renderGlyph (TileGlyph HookTile col)
 323         displaceRender (corner 2) $ renderGlyph (TileGlyph (ArmTile hv False) col)
 324     where
 325         col = dim white
 326
 327 renderGlyph (FullscreenButton fs) = do
 328     thickPolygonR corners 1 $ activeCol (not fs)
 329     thickPolygonR corners' 1 $ activeCol fs
 330     where
 331         activeCol True = opaquify $ dim green
 332         activeCol False = opaquify $ dim red
 333         corners = [ (2/3) **^ (if dir `elem` [hu,neg hu] then edge else innerCorner) dir
 334             | dir <- hexDirs ]
 335         corners' = map (((2/3)**^) . corner) [0..5]
 336
 337 renderGlyph (DisplacedGlyph dir glyph) =
 338     displaceRender (innerCorner dir) $ renderGlyph glyph
 339
 340 renderGlyph (UnfreshGlyph) = do
 341     let col = bright red
 342     renderGlyph (HollowInnerGlyph col)
 343     sequence_ [pixelR (FVec (i/4) 0) col
 344         | i <- [-1..1] ]
 345
 346 playerGlyph col = FilledHexGlyph col
 347
 348 cursorGlyph = HollowGlyph $ bright white
 349
 350 ownedTileGlyph colouring highlight (owner,t) =
 351     let col = colourOf colouring owner
 352     in TileGlyph t $ (if owner `elem` highlight then bright else dim) col
 353
 354 drawCursorAt :: Maybe HexPos -> RenderM ()
 355 drawCursorAt (Just pos) = drawAt cursorGlyph pos
 356 drawCursorAt _ = return ()
 357
 358 drawBasicBG :: Int -> RenderM ()
 359 drawBasicBG maxR = sequence_ [ drawAtRel (HollowGlyph $ colAt v) v | v <- hexDisc maxR ]
 360     where
 361         colAt v@(HexVec hx hy hz) = let
 362                 [r,g,b] = map (\h -> fi $ ((0xff*)$ 5 + abs h)`div`maxR) [hx,hy,hz]
 363                 a = fi $ (0x70 * (maxR - abs (hexLen v)))`div`maxR
 364             in rgbaToPixel (r,g,b,a)
 365
 366 drawBlocked :: GameState -> PieceColouring -> Bool -> Force -> RenderM ()
 367 drawBlocked st colouring blocking (Torque idx dir) = do
 368     let (pos,arms) = case getpp st idx of
 369             PlacedPiece pos (Pivot arms) -> (pos,arms)
 370             PlacedPiece pos (Hook arm _) -> (pos,[arm])
 371             _ -> (pos,[])
 372         col = if blocking then bright $ purple else dim $ colourOf colouring idx
 373     sequence_ [ drawAt (BlockedArm arm dir col) (arm +^ pos) |
 374         arm <- arms ]
 375 drawBlocked st colouring blocking (Push idx dir) = do
 376     let footprint = plPieceFootprint $ getpp st idx
 377         fullfootprint = fullFootprint st idx
 378         col = bright $ if blocking then purple else orange
 379     sequence_ [ drawAt (BlockedPush dir col) pos
 380         | pos <- footprint
 381         , (dir+^pos) `notElem` fullfootprint ]
 382     -- drawAt (blockedPush dir $ bright orange) $ placedPos $ getpp st idx
 383
 384 drawApplied :: GameState -> PieceColouring -> Force -> RenderM ()
 385 drawApplied st colouring (Torque idx dir) = do
 386     let (pos,arms) = case getpp st idx of
 387             PlacedPiece pos (Pivot arms) -> (pos,arms)
 388             PlacedPiece pos (Hook arm _) -> (pos,[arm])
 389             _ -> (pos,[])
 390         col = dim $ colourOf colouring idx
 391     sequence_ [ drawAt (TurnedArm arm dir col) (arm +^ pos) |
 392             arm <- arms ]
 393 drawApplied _ _ _ = return ()