intricacy-0.7.2: SDLGlyph.hs
-- This file is part of Intricacy
-- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see http://www.gnu.org/licenses/.
module SDLGlyph where
import Graphics.UI.SDL
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.List as List
import Control.Applicative
import System.Random (randomRIO)
import Hex
import SDLRender
import GameState
import GameStateTypes
import BoardColouring
import Physics
import Command
import Util
data ShowBlocks = ShowBlocksBlocking | ShowBlocksAll | ShowBlocksNone
deriving (Eq, Ord, Show, Read)
data Glyph
= TileGlyph Tile Pixel
| SpringGlyph HexDir HexDir SpringExtension HexDir Pixel
| PivotGlyph TorqueDir HexDir Pixel
| ArmGlyph TorqueDir HexDir Pixel
| BlockedArm HexDir TorqueDir Pixel
| TurnedArm HexDir TorqueDir Pixel
| BlockedBlock Tile HexDir Pixel
| BlockedPush HexDir Pixel
| CollisionMarker
| HollowGlyph Pixel
| HollowInnerGlyph Pixel
| FilledHexGlyph Pixel
| ButtonGlyph Pixel
| UseFiveColourButton Bool
| ShowBlocksButton ShowBlocks
| ShowButtonTextButton Bool
| UseSoundsButton Bool
| WhsButtonsButton (Maybe WrHoSel)
| FullscreenButton Bool
| DisplacedGlyph HexDir Glyph
| UnfreshGlyph
deriving (Eq, Ord, Show)
type SizedGlyph = (Glyph,Int)
data CachedGlyphs = CachedGlyphs (Map SizedGlyph Surface) [SizedGlyph]
deriving (Eq, Ord, Show)
emptyCachedGlyphs = CachedGlyphs Map.empty []
maxCachedGlyphs = 100
type RenderM = RenderT (StateT CachedGlyphs IO)
runRenderM :: RenderM a -> CachedGlyphs -> RenderContext -> IO (a,CachedGlyphs)
runRenderM m cgs rc = runStateT (runReaderT m rc) cgs
drawAt :: Glyph -> HexPos -> RenderM ()
drawAt gl pos = do
centre <- asks renderHCentre
drawAtRel gl (pos -^ centre)
drawAtRel :: Glyph -> HexVec -> RenderM ()
drawAtRel gl v = recentreAt v $ renderGlyphCaching gl
renderGlyphCaching :: Glyph -> RenderM ()
-- Glyph caching:
-- We aim to cache glyphs which are "currently" being regularly drawn, so
-- they can be blitted from RAM rather than being drawn afresh each time.
-- Rather than track statistics, we adopt the following probabilistic scheme.
renderGlyphCaching gl = do
CachedGlyphs cmap clist <- lift get
size <- asks renderSize
let sgl = (gl,size)
w = size*2 + 1
h = ysize size*4 + 1
newGlyphSurf = do
-- csurf <- liftIO $ createRGBSurface [] w h 32 0xff000000 0x00ff0000 0x0000ff00 0x000000ff
csurf <- liftIO $ createRGBSurface [] w h 16 0 0 0 0
liftIO $ setColorKey csurf [SrcColorKey,RLEAccel] $ Pixel 0
return csurf
renderOnCache csurf =
let ccxt rc = rc { renderSurf = csurf, renderSCentre = SVec (w`div`2) (h`div`2), renderOffset = zero }
in local ccxt $ renderGlyph gl
addToCache cacheFull csurf = do
CachedGlyphs cmap clist <- lift get
let cmap' = Map.insert sgl csurf cmap
lift $ put $ if cacheFull
then CachedGlyphs (Map.delete (last clist) cmap') (sgl:List.init clist)
else CachedGlyphs cmap' (sgl:clist)
promote = do
CachedGlyphs cmap clist <- lift get
lift $ put $ CachedGlyphs cmap (sgl:List.delete sgl clist)
blitGlyph csurf = do
surf <- asks renderSurf
(x,y) <- renderPos zero
void $ liftIO $ blitSurface csurf Nothing surf $ Just $
Rect (x-w`div`2) (y-h`div`2) (w+1) (h+1)
let cacheFull = Map.size cmap >= maxCachedGlyphs
let mcsurf = Map.lookup sgl cmap
-- with probability 1 in (maxCachedGlyphs`div`2), we put this glyph at the
-- head of the cached list, throwing away the tail to make room if needed.
cacheIt <- (((cacheable &&) . (not cacheFull ||)) <$>) $
liftIO $ (==0) <$> randomRIO (0::Int,maxCachedGlyphs`div`2)
case mcsurf of
Nothing -> if cacheIt
then do
csurf <- newGlyphSurf
renderOnCache csurf
addToCache cacheFull csurf
blitGlyph csurf
else
renderGlyph gl
Just csurf -> do
when cacheIt promote
blitGlyph csurf
where
cacheable = case gl of
-- some glyphs need to be drawn with blending - those involving
-- anti-aliasing which bleed over the edge of the hex or which
-- may be drawn on top of an existing glyph.
-- TODO: we should find a way to deal with at least some of these;
-- springs in particular are common and expensive to draw.
-- Maybe we could truncate the spring glyphs to a hex?
TileGlyph (BlockTile adjs) _ -> null adjs
TileGlyph (SpringTile extn dir) _ -> False
SpringGlyph _ _ _ _ _ -> False
FilledHexGlyph _ -> False
HollowGlyph _ -> False
BlockedBlock _ _ _ -> False
BlockedPush _ _ -> False
CollisionMarker -> False
DisplacedGlyph _ _ -> False
_ -> True
renderGlyph :: Glyph -> RenderM ()
renderGlyph (TileGlyph (BlockTile adjs) col) =
rimmedPolygonR corners col $ bright col
where
corners = concat [
if or $ map adjAt [0,1]
then [corner $ hextant dir]
else if adjAt $ -1
then []
else [innerCorner dir]
| dir <- hexDirs
, let adjAt r = rotate r dir `elem` adjs
]
renderGlyph (TileGlyph (SpringTile extn dir) col) =
renderGlyph $ SpringGlyph zero zero extn dir col
renderGlyph (TileGlyph (PivotTile dir) col) = do
renderGlyph $ PivotGlyph 0 dir col
renderGlyph (TileGlyph (ArmTile dir _) col) =
renderGlyph $ ArmGlyph 0 dir col
renderGlyph (TileGlyph HookTile col) =
rimmedCircleR zero (7/8) col $ bright col
renderGlyph (TileGlyph (WrenchTile mom) col) = do
rimmedCircleR zero (1/3) col $ bright col
when (mom /= zero) $
let
from = innerCorner $ neg mom
to = edge $ neg mom
shifts = [ (1/2) **^ (b -^ a)
| rot <- [-1,0,1]
, let a = innerCorner $ neg mom
, let b = innerCorner $ rotate rot $ neg mom
]
in sequence_
[ aaLineR (from+^shift) (to+^shift) $ col
| shift <- shifts ]
renderGlyph (TileGlyph BallTile col) =
rimmedCircleR zero (7/8) (faint col) (obscure col)
renderGlyph (SpringGlyph rootDisp endDisp extn dir col) =
thickLinesR points 1 $ brightness col
where
n :: Int
n = 3*case extn of
Stretched -> 1
Relaxed -> 2
Compressed -> 4
brightness = dim
dir' = if dir == zero then hu else dir
s = corner (hextant dir' - 1) +^ innerCorner endDisp
off = corner (hextant dir') +^ innerCorner endDisp
e = corner (hextant dir' - 3) +^ innerCorner rootDisp
points = [ b +^ (fi i / fi n) **^ (e -^ s)
| i <- [0..n]
, i`mod`3 /= 1
, let b = if i`mod`3==0 then s else off ]
renderGlyph (PivotGlyph rot dir col) = do
rimmedCircleR zero (7/8) col $ bright col
when (dir /= zero)
$ aaLineR from to $ bright col
return ()
where
from = rotFVec th c $ (7/8) **^ edge (neg dir)
to = rotFVec th c $ (7/8) **^ edge dir
c = FVec 0 0
th = - fi rot * pi / 12
renderGlyph (ArmGlyph rot dir col) =
thickLineR from to 1 col
where
dir' = if dir == zero then hu else dir
from = rotFVec th c $ edge $ neg dir'
to = rotFVec th c $ innerCorner dir'
c = (2 **^ edge (neg dir'))
th = - fi rot * pi / 12
renderGlyph (BlockedArm armdir tdir col) =
aaLineR from to col
where
from = innerCorner $ rotate (2*tdir) armdir
to = edge $ rotate tdir armdir
renderGlyph (TurnedArm armdir tdir col) =
sequence_ [ arcR c r a1 a2 col | r <- [8/4,9/4] ]
where
c = hexVec2FVec $ neg armdir
a0 = fi $ -60*hextant armdir
a1' = a0 + fi tdir * 10
a2' = a0 + fi tdir * 30
a1 = min a1' a2'
a2 = max a1' a2'
renderGlyph (BlockedBlock tile dir col) =
displaceRender shift $ renderGlyph (TileGlyph tile col)
where shift = innerCorner dir -^ edge dir
renderGlyph (BlockedPush dir col) = do
thickLineR zero tip 1 col
thickLineR tip (arms!!0) 1 col
thickLineR tip (arms!!1) 1 col
where
tip@(FVec tx ty) = edge dir
arms = [ FVec ((tx/2) + d*ty/4) (ty/2 - d*tx/4) | d <- [-1,1] ]
renderGlyph CollisionMarker = do
-- rimmedCircle surf centre (size`div`3) (bright purple) $ bright purple
aaLineR start end $ col
aaCircleR zero rad col
where
[start,end] = map (((1/2)**^) . corner) [0,3]
rad = ylen
col = dim purple
renderGlyph (HollowGlyph col) =
aaPolygonR corners $ opaquify col
where corners = map corner [0..5]
renderGlyph (HollowInnerGlyph col) =
aaPolygonR corners $ opaquify col
where corners = map innerCorner hexDirs
renderGlyph (FilledHexGlyph col) =
rimmedPolygonR corners col $ brightish col
where corners = map corner [0..5]
renderGlyph (ButtonGlyph col) =
renderGlyph (TileGlyph (BlockTile []) col)
renderGlyph (UseFiveColourButton using) =
rescaleRender (1/2) $ sequence_ [
displaceRender (corner h) $ renderGlyph
(TileGlyph (BlockTile [])
(dim $ colourWheel (if using then h`div`2 else 1)))
| h <- [0,2,4] ]
renderGlyph (ShowBlocksButton showing) = do
renderGlyph (TileGlyph (BlockTile []) (dim red))
when (showing == ShowBlocksAll) $
renderGlyph (BlockedPush hu (bright orange))
when (showing /= ShowBlocksNone) $
renderGlyph (BlockedPush hw (bright purple))
renderGlyph (ShowButtonTextButton showing) = do
rescaleRender (1/2) $ displaceRender (edge (neg hu)) $
renderGlyph (ButtonGlyph (dim yellow))
when showing $
sequence_ [ pixelR (FVec (1/3 + i/4) (-1/4)) (bright white) | i <- [-1..1] ]
renderGlyph (UseSoundsButton use) = do
sequence [ arcR (FVec (-2/3) 0) r (-20) 20
(if use then bright green else dim red)
| r <- [1/3,2/3,1] ]
when (not use) $
aaLineR (innerCorner hw) (innerCorner $ neg hw) $ dim red
renderGlyph (WhsButtonsButton Nothing) = rescaleRender (1/3) $ do
renderGlyph (ButtonGlyph (dim red))
sequence_ [ displaceRender ((3/2) **^ edge dir) $
renderGlyph (ButtonGlyph (dim purple))
| dir <- hexDirs ]
renderGlyph (WhsButtonsButton (Just whs)) = rescaleRender (1/2) $ do
when (whs /= WHSHook) $
displaceRender (corner 0) $ renderGlyph (TileGlyph (WrenchTile zero) col)
when (whs /= WHSWrench) $ do
displaceRender (corner 4) $ renderGlyph (TileGlyph HookTile col)
displaceRender (corner 2) $ renderGlyph (TileGlyph (ArmTile hv False) col)
where
col = dim white
renderGlyph (FullscreenButton fs) = do
thickPolygonR corners 1 $ activeCol (not fs)
thickPolygonR corners' 1 $ activeCol fs
where
activeCol True = opaquify $ dim green
activeCol False = opaquify $ dim red
corners = [ (2/3) **^ (if dir `elem` [hu,neg hu] then edge else innerCorner) dir
| dir <- hexDirs ]
corners' = map (((2/3)**^) . corner) [0..5]
renderGlyph (DisplacedGlyph dir glyph) =
displaceRender (innerCorner dir) $ renderGlyph glyph
renderGlyph (UnfreshGlyph) = do
let col = bright red
renderGlyph (HollowInnerGlyph col)
sequence_ [pixelR (FVec (i/4) 0) col
| i <- [-1..1] ]
playerGlyph col = FilledHexGlyph col
cursorGlyph = HollowGlyph $ bright white
ownedTileGlyph colouring highlight (owner,t) =
let col = colourOf colouring owner
in TileGlyph t $ (if owner `elem` highlight then bright else dim) col
drawCursorAt :: Maybe HexPos -> RenderM ()
drawCursorAt (Just pos) = drawAt cursorGlyph pos
drawCursorAt _ = return ()
drawBasicBG :: Int -> RenderM ()
drawBasicBG maxR = sequence_ [ drawAtRel (HollowGlyph $ colAt v) v | v <- hexDisc maxR ]
where
colAt v@(HexVec hx hy hz) = let
[r,g,b] = map (\h -> fi $ ((0xff*)$ 5 + abs h)`div`maxR) [hx,hy,hz]
a = fi $ (0x70 * (maxR - abs (hexLen v)))`div`maxR
in rgbaToPixel (r,g,b,a)
drawBlocked :: GameState -> PieceColouring -> Bool -> Force -> RenderM ()
drawBlocked st colouring blocking (Torque idx dir) = do
let (pos,arms) = case getpp st idx of
PlacedPiece pos (Pivot arms) -> (pos,arms)
PlacedPiece pos (Hook arm _) -> (pos,[arm])
_ -> (pos,[])
col = if blocking then bright $ purple else dim $ colourOf colouring idx
sequence_ [ drawAt (BlockedArm arm dir col) (arm +^ pos) |
arm <- arms ]
drawBlocked st colouring blocking (Push idx dir) = do
let footprint = plPieceFootprint $ getpp st idx
fullfootprint = fullFootprint st idx
col = bright $ if blocking then purple else orange
sequence_ [ drawAt (BlockedPush dir col) pos
| pos <- footprint
, (dir+^pos) `notElem` fullfootprint ]
-- drawAt (blockedPush dir $ bright orange) $ placedPos $ getpp st idx
drawApplied :: GameState -> PieceColouring -> Force -> RenderM ()
drawApplied st colouring (Torque idx dir) = do
let (pos,arms) = case getpp st idx of
PlacedPiece pos (Pivot arms) -> (pos,arms)
PlacedPiece pos (Hook arm _) -> (pos,[arm])
_ -> (pos,[])
col = dim $ colourOf colouring idx
sequence_ [ drawAt (TurnedArm arm dir col) (arm +^ pos) |
arm <- arms ]
drawApplied _ _ _ = return ()