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