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     | PathGlyph HexDir Pixel
  54     | GateGlyph HexDir Pixel
  55     | UseFiveColourButton Bool
  56     | ShowBlocksButton ShowBlocks
  57     | ShowButtonTextButton Bool
  58     | UseSoundsButton Bool
  59     | WhsButtonsButton (Maybe WrHoSel)
  60     | FullscreenButton Bool
  61     | DisplacedGlyph HexDir Glyph
  62     | UnfreshGlyph
  63     deriving (Eq, Ord, Show)
  64
  65 type SizedGlyph = (Glyph,Int)
  66 data CachedGlyphs = CachedGlyphs (Map SizedGlyph Surface) [SizedGlyph]
  67     deriving (Eq, Ord, Show)
  68 emptyCachedGlyphs = CachedGlyphs Map.empty []
  69 maxCachedGlyphs = 100
  70
  71 type RenderM = RenderT (StateT CachedGlyphs IO)
  72 runRenderM :: RenderM a -> CachedGlyphs -> RenderContext -> IO (a,CachedGlyphs)
  73 runRenderM m cgs rc = runStateT (runReaderT m rc) cgs
  74
  75 drawAt :: Glyph -> HexPos -> RenderM ()
  76 drawAt gl pos = do
  77         centre <- asks renderHCentre
  78         drawAtRel gl (pos -^ centre)
  79
  80 drawAtRel :: Glyph -> HexVec -> RenderM ()
  81 drawAtRel gl v = recentreAt 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), renderOffset = zero }
 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 any adjAt [0,1]
 159                 then [corner $ hextant dir]
 160                 else [innerCorner dir | not (adjAt $ -1)]
 161                 | dir <- hexDirs
 162                 , let adjAt r = rotate r dir `elem` adjs
 163                 ]
 164
 165 renderGlyph (TileGlyph (SpringTile extn dir) col) =
 166     renderGlyph $ SpringGlyph zero zero extn dir col
 167
 168 renderGlyph (TileGlyph (PivotTile dir) col) = do
 169     renderGlyph $ PivotGlyph 0 dir col
 170
 171 renderGlyph (TileGlyph (ArmTile dir _) col) =
 172     renderGlyph $ ArmGlyph 0 dir col
 173
 174 renderGlyph (TileGlyph HookTile col) =
 175     rimmedCircleR zero (7/8) col $ bright col
 176
 177 renderGlyph (TileGlyph (WrenchTile mom) col) = do
 178     rimmedCircleR zero (1/3) col $ bright col
 179     when (mom /= zero) $
 180         let
 181             from = innerCorner $ neg mom
 182             to = edge $ neg mom
 183             shifts = [(1 / 2) **^ (b -^ a) |
 184                let a = innerCorner $ neg mom,
 185                rot <- [- 1, 0, 1],
 186                let b = innerCorner $ rotate rot $ neg mom]
 187         in sequence_
 188             [ aaLineR (from+^shift) (to+^shift) col
 189             | shift <- shifts ]
 190
 191 renderGlyph (TileGlyph BallTile col) =
 192     rimmedCircleR zero (7/8) (faint col) (obscure col)
 193
 194 renderGlyph (SpringGlyph rootDisp endDisp extn dir col) =
 195     thickLinesR points 1 $ brightness col
 196         where
 197             n :: Int
 198             n = 3*case extn of
 199                 Stretched  -> 1
 200                 Relaxed    -> 2
 201                 Compressed -> 4
 202             brightness = dim
 203             dir' = if dir == zero then hu else dir
 204             s = corner (hextant dir' - 1) +^ innerCorner endDisp
 205             off = corner (hextant dir') +^ innerCorner endDisp
 206             e = corner (hextant dir' - 3) +^ innerCorner rootDisp
 207             points = [ b +^ (fi i / fi n) **^ (e -^ s)
 208                 | i <- [0..n]
 209                 , i`mod`3 /= 1
 210                 , let b = if i`mod`3==0 then s else off ]
 211
 212 renderGlyph (PivotGlyph rot dir col) = do
 213     rimmedCircleR zero (7/8) col $ bright col
 214     when (dir /= zero)
 215         $ aaLineR from to $ bright col
 216         where
 217             from = rotFVec th c $ (7/8) **^ edge (neg dir)
 218             to = rotFVec th c $ (7/8) **^ edge dir
 219             c = FVec 0 0
 220             th = - fi rot * pi / 12
 221
 222 renderGlyph (ArmGlyph rot dir col) =
 223     thickLineR from to 1 $ bright col
 224         where
 225             dir' = if dir == zero then hu else dir
 226             from = rotFVec th c $ edge $ neg dir'
 227             to = rotFVec th c $ innerCorner dir'
 228             c = 2 **^ edge (neg dir')
 229             th = - fi rot * pi / 12
 230
 231 renderGlyph (BlockedArm armdir tdir col) =
 232     aaLineR from to col
 233         where
 234             from = innerCorner $ rotate (2*tdir) armdir
 235             to = edge $ rotate tdir armdir
 236
 237 renderGlyph (TurnedArm armdir tdir col) =
 238     sequence_ [ arcR c r a1 a2 col | r <- [8/4,9/4] ]
 239     where
 240         c = hexVec2FVec $ neg armdir
 241         a0 = fi $ -60*hextant armdir
 242         a1' = a0 + fi tdir * 10
 243         a2' = a0 + fi tdir * 30
 244         a1 = min a1' a2'
 245         a2 = max a1' a2'
 246
 247 renderGlyph (BlockedBlock tile dir col) =
 248     displaceRender shift $ renderGlyph (TileGlyph tile col)
 249         where shift = innerCorner dir -^ edge dir
 250
 251 renderGlyph (BlockedPush dir col) = do
 252     thickLineR zero tip 1 col
 253     thickLineR tip (head arms) 1 col
 254     thickLineR tip (arms!!1) 1 col
 255     where
 256         tip@(FVec tx ty) = edge dir
 257         arms = [ FVec ((tx/2) + d*ty/4) (ty/2 - d*tx/4) | d <- [-1,1] ]
 258
 259 renderGlyph CollisionMarker = do
 260     -- rimmedCircle surf centre (size`div`3) (bright purple) $ bright purple
 261     aaLineR start end col
 262     aaCircleR zero rad col
 263     where
 264         [start,end] = map (((1/2)**^) . corner) [0,3]
 265         rad = ylen
 266         col = dim purple
 267
 268 renderGlyph (HollowGlyph col) =
 269     aaPolygonR corners $ opaquify col
 270     where corners = map corner [0..5]
 271 renderGlyph (HollowInnerGlyph col) =
 272     aaPolygonR corners $ opaquify col
 273     where corners = map innerCorner hexDirs
 274
 275 renderGlyph (FilledHexGlyph col) =
 276     rimmedPolygonR corners col $ brightish col
 277     where corners = map corner [0..5]
 278
 279 renderGlyph (ButtonGlyph col) =
 280     renderGlyph (TileGlyph (BlockTile []) col)
 281
 282 renderGlyph (PathGlyph dir col) = do
 283     aaLineR from to col
 284     where
 285     from = edge $ neg dir
 286     to = edge dir
 287
 288 renderGlyph (GateGlyph dir col) = do
 289     aaLineR from to col
 290     where
 291     from = corner $ 1 + hextant dir
 292     to = corner $ 4 + hextant dir
 293
 294 renderGlyph (UseFiveColourButton using) =
 295     rescaleRender (1/2) $ sequence_ [
 296         displaceRender (corner h) $ renderGlyph
 297             (TileGlyph (BlockTile [])
 298                 (dim $ colourWheel (if using then h`div`2 else 1)))
 299         | h <- [0,2,4] ]
 300
 301 renderGlyph (ShowBlocksButton showing) = do
 302     renderGlyph (TileGlyph (BlockTile []) (dim red))
 303     when (showing == ShowBlocksAll) $
 304         renderGlyph (BlockedPush hu (bright orange))
 305     when (showing /= ShowBlocksNone) $
 306         renderGlyph (BlockedPush hw (bright purple))
 307
 308 renderGlyph (ShowButtonTextButton showing) = do
 309     rescaleRender (1/2) $ displaceRender (edge (neg hu)) $
 310         renderGlyph (ButtonGlyph (dim yellow))
 311     when showing $
 312         sequence_ [ pixelR (FVec (1/3 + i/4) (-1/4)) (bright white) | i <- [-1..1] ]
 313
 314 renderGlyph (UseSoundsButton use) = do
 315     sequence_ [ arcR (FVec (-2/3) 0) r (-20) 20
 316             (if use then bright green else dim red)
 317         | r <- [1/3,2/3,1] ]
 318     unless use $
 319         aaLineR (innerCorner hw) (innerCorner $ neg hw) $ dim red
 320
 321 renderGlyph (WhsButtonsButton Nothing) = rescaleRender (1/3) $ do
 322     renderGlyph (ButtonGlyph (dim red))
 323     sequence_ [ displaceRender ((3/2) **^ edge dir) $
 324             renderGlyph (ButtonGlyph (dim purple))
 325         | dir <- hexDirs ]
 326 renderGlyph (WhsButtonsButton (Just whs)) = rescaleRender (1/3) $ do
 327     when (whs /= WHSHook) $
 328         displaceRender (corner 0) $ renderGlyph (TileGlyph (WrenchTile zero) col)
 329     when (whs /= WHSWrench) $ do
 330         displaceRender (corner 4) $ renderGlyph (TileGlyph HookTile col)
 331         displaceRender (corner 2) $ renderGlyph (TileGlyph (ArmTile hv False) col)
 332     where
 333         col = dim white
 334
 335 renderGlyph (FullscreenButton fs) = do
 336     thickPolygonR corners 1 $ activeCol (not fs)
 337     thickPolygonR corners' 1 $ activeCol fs
 338     where
 339         activeCol True  = opaquify $ dim green
 340         activeCol False = opaquify $ dim red
 341         corners = [ (2/3) **^ (if dir `elem` [hu,neg hu] then edge else innerCorner) dir
 342             | dir <- hexDirs ]
 343         corners' = map (((2/3)**^) . corner) [0..5]
 344
 345 renderGlyph (DisplacedGlyph dir glyph) =
 346     displaceRender (innerCorner dir) $ renderGlyph glyph
 347
 348 renderGlyph UnfreshGlyph = do
 349     let col = bright red
 350     renderGlyph (HollowInnerGlyph col)
 351     sequence_ [pixelR (FVec (i/4) 0) col
 352         | i <- [-1..1] ]
 353
 354 playerGlyph = FilledHexGlyph
 355
 356 cursorGlyph = HollowGlyph $ bright white
 357
 358 ownedTileGlyph colouring highlight (owner,t) =
 359     let col = colourOf colouring owner
 360     in TileGlyph t $ (if owner `elem` highlight then bright else dim) col
 361
 362 drawCursorAt :: Maybe HexPos -> RenderM ()
 363 drawCursorAt (Just pos) = drawAt cursorGlyph pos
 364 drawCursorAt _          = return ()
 365
 366 drawBasicBG :: Int -> RenderM ()
 367 drawBasicBG maxR = sequence_ [ drawAtRel (HollowGlyph $ colAt v) v | v <- hexDisc maxR ]
 368     where
 369         colAt v@(HexVec hx hy hz) = let
 370                 [r,g,b] = map (\h -> fi $ 0xff * (5 + abs h)`div`maxR) [hx,hy,hz]
 371                 a = fi $ (0x70 * (maxR - abs (hexLen v)))`div`maxR
 372             in rgbaToPixel (r,g,b,a)
 373
 374 drawBlocked :: GameState -> PieceColouring -> Bool -> Force -> RenderM ()
 375 drawBlocked st colouring blocking (Torque idx dir) = do
 376     let (pos,arms) = case getpp st idx of
 377             PlacedPiece pos (Pivot arms) -> (pos,arms)
 378             PlacedPiece pos (Hook arm _) -> (pos,[arm])
 379             _                            -> (pos,[])
 380         col = if blocking then bright purple else dim $ colourOf colouring idx
 381     sequence_ [ drawAt (BlockedArm arm dir col) (arm +^ pos) |
 382         arm <- arms ]
 383 drawBlocked st colouring blocking (Push idx dir) = do
 384     let footprint = plPieceFootprint $ getpp st idx
 385         fullfootprint = fullFootprint st idx
 386         col = bright $ if blocking then purple else orange
 387     sequence_ [ drawAt (BlockedPush dir col) pos
 388         | pos <- footprint
 389         , (dir+^pos) `notElem` fullfootprint ]
 390     -- drawAt (blockedPush dir $ bright orange) $ placedPos $ getpp st idx
 391
 392 drawApplied :: GameState -> PieceColouring -> Force -> RenderM ()
 393 drawApplied st colouring (Torque idx dir) = do
 394     let (pos,arms) = case getpp st idx of
 395             PlacedPiece pos (Pivot arms) -> (pos,arms)
 396             PlacedPiece pos (Hook arm _) -> (pos,[arm])
 397             _                            -> (pos,[])
 398         col = dim $ colourOf colouring idx
 399     sequence_ [ drawAt (TurnedArm arm dir col) (arm +^ pos) |
 400             arm <- arms ]
 401 drawApplied _ _ _ = return ()