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