-- 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 SDLRender where
import Graphics.UI.SDL
import Graphics.UI.SDL.Primitives
import qualified Graphics.UI.SDL.TTF as TTF
import Data.Monoid
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 Data.List (maximumBy)
import Data.Function (on)
import GHC.Int (Int16)
import Control.Applicative hiding ((<*>))
import System.Random (randomRIO)
import Hex
import GameState
import GameStateTypes
import BoardColouring
import Physics
import Command
import Util
-- aaPolygon seems to be a bit buggy in sdl-gfx-0.6.0
aaPolygon' surf verts col =
aaLines surf (verts ++ take 1 verts) col
-- aaCircle too
aaCircle' surf x y rad col =
if (rad == 1) then pixel surf x y col
else aaCircle surf x y rad col
aaLines surf verts col =
sequence_ [ aaLine surf x y x' y' col |
((x,y),(x',y')) <- zip (take (length verts - 1) verts) (drop 1 verts) ]
rimmedPolygon surf verts fillCol rimCol = do
filledPolygon surf verts fillCol
aaPolygon' surf verts $ opaquify rimCol
return ()
circleAt surf centre@(SVec x y) rad col =
aaCircle' surf (fi x) (fi y) (fi rad) col
filledCircleAt surf centre@(SVec x y) rad col =
filledCircle surf (fi x) (fi y) (fi rad) col
rimmedCircle surf centre@(SVec x y) rad fillCol rimCol = void $ do
filledCircleAt surf centre rad fillCol
circleAt surf centre rad $ opaquify rimCol
thickLine :: Surface -> (Int16,Int16) -> (Int16,Int16) -> Float -> Pixel -> IO ()
thickLine surf from@(x,y) to@(x',y') thickness col = do
let (dx,dy) = (x'-x,y'-y)
[rdx,rdy] = map fi [dx,dy]
s = thickness / (sqrt $ rdx^2 + rdy^2)
perp@(px,py) = (round $ s*rdy, round $ s*(-rdx))
mperp = (-px,-py)
addHalf (a,b) (c,d) = ( (2*a + c) `div` 2, (2*b + d) `div` 2 )
rimmedPolygon surf
(map (uncurry addHalf) [(from,perp),(to,perp),(from,mperp),(to,mperp)])
(dim col) (bright col)
thickLines surf verts thickness col =
sequence_ [ thickLine surf v v' thickness col |
(v,v') <- zip (take (length verts - 1) verts) (drop 1 verts) ]
thickPolygon surf verts thickness col =
thickLines surf (verts ++ take 1 verts) thickness col
ysize :: Int -> Int
ysize = (map (\size -> round $ fi size / sqrt 3) [0..] !!)
corner :: Integral i => SVec -> Int -> Int -> (i,i)
corner (SVec x y) size hextant = (fi $ x+dx, fi $ y+dy)
where
[dx,dy] = f hextant
f 0 = [size, -ysize size]
f 1 = [0, -2*ysize size]
f 2 = [-size, -ysize size]
f n | n < 6 = let [x,y] = f (5-n) in [x,-y]
| n < 0 = f (6-n)
| otherwise = f (n`mod`6)
innerCorner :: Integral i => SVec -> Int -> HexDir -> (i,i)
innerCorner (SVec x y) size dir = (fi $ x+dx, fi $ y+dy)
where
[dx,dy] = f dir
f dir
| dir == hu = [2*isize, 0]
| dir == hv = [-isize, -ysize size]
| dir == hw = [-isize, ysize size]
| not (isHexDir dir) = error "innerCorner: not a hexdir"
| otherwise = map (\z -> -z) $ f $ neg dir
isize = size `div` 3
edge :: Integral i => SVec -> Int -> HexDir -> (i,i)
edge (SVec x y) size dir = (fi $ x+dx, fi $ y+dy)
where
[dx,dy] = f dir
f dir
| dir == hu = [size, 0]
| dir == hv = [-size`div`2, -3*ysize size`div`2]
| dir == hw = [-size`div`2, 3*ysize size`div`2]
| not (isHexDir dir) = error "edge: not a hexdir"
| otherwise = map (\z -> -z) $ f $ neg dir
data ShowBlocks = ShowBlocksBlocking | ShowBlocksAll | ShowBlocksNone
deriving (Eq, Ord, Show, Read)
data Glyph
= TileGlyph Tile 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
| 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
renderGlyphCaching :: Glyph -> SVec -> Int -> Surface -> 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 centre size surf = do
CachedGlyphs cmap clist <- lift get
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
liftIO $ renderGlyph gl centre size surf
Just csurf -> do
when cacheIt promote
blitGlyph csurf
where
sgl = (gl,size)
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
FilledHexGlyph _ -> False
HollowGlyph _ -> False
BlockedBlock _ _ _ -> False
BlockedPush _ _ -> False
CollisionMarker -> False
_ -> True
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 =
liftIO $ renderGlyph gl (SVec (w`div`2) (h`div`2)) size csurf
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 =
let SVec x y = centre
in void $ liftIO $ blitSurface csurf Nothing surf $ Just $
Rect (x-w`div`2) (y-h`div`2) (w+1) (h+1)
renderGlyph :: Glyph -> SVec -> Int -> Surface -> IO ()
renderGlyph (TileGlyph (BlockTile adjs) col) centre size surf =
rimmedPolygon surf corners col $ bright col
where
corners = concat [
if or $ map adjAt [0,1]
then [corner centre size $ hextant dir]
else if adjAt $ -1
then []
else [innerCorner centre size dir]
| dir <- hexDirs
, let adjAt r = rotate r dir `elem` adjs
]
renderGlyph (TileGlyph (SpringTile extn dir) col) centre size surf =
thickLines surf points 1 $ brightness col
where
n = 3*case extn of
Stretched -> 1
Relaxed -> 2
Compressed -> 4
brightness = if extn == Relaxed then dim else bright
dir' = if dir == zero then hu else dir
(sx,sy) = corner centre size (hextant dir' - 1)
(offx,offy) = corner centre size (hextant dir')
(ex,ey) = corner centre size (hextant dir' - 3)
points = [ (x+dx,y+dy)
| i <- [0..n]
, i`mod`3 /= 1
, let (x,y) = if i`mod`3==0 then (sx,sy) else (offx,offy)
, let (dx,dy) = ((i*(ex-sx))`div`n, (i*(ey-sy))`div`n) ]
renderGlyph (TileGlyph (PivotTile dir) col) centre size surf = do
rimmedCircle surf centre rad col $ bright col
when (dir /= zero)
$ void $ aaLine surf `uncurry` from `uncurry` to $ bright col
return ()
where
rad = (7*size)`div`8
from = edge centre rad $ neg dir
to = edge centre rad dir
renderGlyph (TileGlyph (ArmTile dir _) col) centre size surf =
void $ thickLine surf from to 1 col
where
dir' = if dir == zero then hu else dir
from = edge centre size $ neg dir'
to = innerCorner centre size dir'
renderGlyph (TileGlyph HookTile col) centre size surf =
rimmedCircle surf centre rad col $ bright col
where
rad = (7*size)`div`8
renderGlyph (TileGlyph (WrenchTile mom) col) centre size surf = do
rimmedCircle surf centre (size`div`3) col $ bright col
when (mom /= zero) $
let
(fx,fy) = innerCorner centre size $ neg mom
(tx,ty) = edge centre size $ neg mom
shifts = map (map (`div` 2)) $
[ [ x1-x0, y1-y0 ]
| rot <- [-1,0,1]
, let (x0,y0) = innerCorner centre size $ neg mom
, let (x1,y1) = innerCorner centre size $ rotate rot $ neg mom
]
in sequence_
[ aaLine surf (fx+dx) (fy+dy) (tx+dx) (ty+dy) $ col
| [dx,dy] <- shifts ]
renderGlyph (TileGlyph BallTile col) centre size surf =
rimmedCircle surf centre rad (faint col) (obscure col)
where rad = (7*size)`div`8
renderGlyph (BlockedArm armdir tdir col) centre size surf =
void $ aaLine surf `uncurry` from `uncurry` to $ col
where
from = innerCorner centre size $ rotate (2*tdir) armdir
to = edge centre size $ rotate tdir armdir
renderGlyph (TurnedArm armdir tdir col) centre size surf =
sequence_ [ arc surf (fi x) (fi y) (fi $ n*size `div` 4)
a1 a2 col | n <- [8,9] ]
where
SVec x y = centre <+> hexVec2SVec size (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) centre size surf =
renderGlyph (TileGlyph tile col) (shift <+> centre) size surf
where
shift = SVec (x'-x) (y'-y)
(x,y) = innerCorner centre size dir
(x',y') = edge centre size dir
renderGlyph (BlockedPush dir col) centre size surf = do
{-
void $ rimmedPolygon surf verts (obscure col) (dim col)
where verts =
[ innerCorner centre size $ rotate 1 dir
, innerCorner centre size $ rotate (-1) dir
, innerCorner centre size dir ]
-}
void $ thickLine surf base tip 1 col
--void $ aaLine surf `uncurry` from' `uncurry` to' $ col
void $ thickLine surf tip (arms!!0) 1 col
void $ thickLine surf tip (arms!!1) 1 col
where
--base@(bx,by) = innerCorner centre size dir
SVec bx' by' = centre
base@(bx,by) = (fi bx',fi by')
tip@(tx,hy) = edge centre size dir
arms = [(bx + (tx-bx)`div`2 + dir*(hy-by)`div`4,
by + (hy-by)`div`2 - dir*(tx-bx)`div`4) | dir <- [-1,1]]
--from' = corner centre size $ hextant dir
--to' = corner centre size $ (hextant dir) - 1
renderGlyph CollisionMarker centre@(SVec x y) size surf = void $ do
-- rimmedCircle surf centre (size`div`3) (bright purple) $ bright purple
aaLine surf `uncurry` start `uncurry` end $ col
circleAt surf centre rad col
where
[start,end] = map (corner centre (size`div`2)) [0,3]
rad = ysize size
col = dim purple
renderGlyph (HollowGlyph col) centre size surf =
aaPolygon' surf corners $ opaquify col
where corners = map (corner centre size) [0..5]
renderGlyph (HollowInnerGlyph col) centre size surf =
aaPolygon' surf corners $ opaquify col
where corners = [ innerCorner centre size dir | dir <- hexDirs ]
renderGlyph (FilledHexGlyph col) centre size surf =
rimmedPolygon surf corners col $ brightish col
where corners = map (corner centre size) [0..5]
renderGlyph (ButtonGlyph col) centre size surf =
renderGlyph (TileGlyph (BlockTile []) col) centre size surf
renderGlyph (UseFiveColourButton using) centre size surf = do
mapM_ (\h -> renderGlyph (TileGlyph (BlockTile [])
(dim $ colourWheel (if using then h`div`2 else 1)))
(SVec `uncurry` corner centre (size`div`2) h) (size`div`2) surf)
[0,2,4]
renderGlyph (ShowBlocksButton showing) centre size surf = do
renderGlyph (TileGlyph (BlockTile []) (dim red)) centre size surf
when (showing == ShowBlocksAll) $
renderGlyph (BlockedPush hu (bright orange)) centre size surf
when (showing /= ShowBlocksNone) $
renderGlyph (BlockedPush hw (bright purple)) centre size surf
renderGlyph (ShowButtonTextButton showing) centre@(SVec x y) size surf = do
renderGlyph (ButtonGlyph (dim yellow)) (SVec `uncurry` edge centre (size`div`2) (neg hu)) (size`div`2) surf
when showing $
sequence_ [ pixel surf (fi $ x+size`div`3+(i*size`div`4)) (fi $ y - size`div`4) (bright white)
| i <- [-1..1] ]
renderGlyph (UseSoundsButton use) centre@(SVec x y) size surf = sequence_
[ arc surf (fi $ x - (size`div`2)) (fi y) r (-20) 20
(if use then bright green else dim red)
| r <- map fi $ map (*(size`div`3)) [1,2,3] ]
renderGlyph (WhsButtonsButton Nothing) centre size surf =
renderGlyph (ButtonGlyph (dim red)) centre (size`div`3) surf
>> sequence_ [ renderGlyph (ButtonGlyph (dim purple))
(SVec `uncurry` edge centre (size`div`2) dir) (size`div`3) surf
| dir <- hexDirs ]
renderGlyph (WhsButtonsButton (Just whs)) centre size surf = do
when (whs /= WHSHook) $
renderGlyph (TileGlyph (WrenchTile zero) col) (miniCentre 0) miniSize surf
when (whs /= WHSWrench) $ do
renderGlyph (TileGlyph HookTile col) (miniCentre 4) miniSize surf
renderGlyph (TileGlyph (ArmTile hv False) col) (miniCentre 2) miniSize surf
where
miniSize = size `div` 2
miniCentre h = SVec `uncurry` corner centre miniSize h
col = dim white
renderGlyph (FullscreenButton fs) centre size surf = do
thickPolygon surf corners 1 $ activeCol (not fs)
thickPolygon surf corners' 1 $ activeCol fs
where
activeCol True = opaquify $ dim green
activeCol False = opaquify $ dim red
size' = (2*size`div`3)
corners = [ (if dir `elem` [hu,neg hu] then edge else innerCorner) centre size' dir
| dir <- hexDirs ]
corners' = map (corner centre size') [0..5]
renderGlyph (UnfreshGlyph) centre@(SVec x y) size surf = do
let col = bright red
renderGlyph (HollowInnerGlyph col) centre size surf
sequence_ [pixel surf (fi $ x+(i*size`div`4)) (fi y) 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
setPixelAlpha alpha (Pixel v) = Pixel $ v `div` 0x100 * 0x100 + alpha
bright = setPixelAlpha 0xff
brightish = setPixelAlpha 0xc0
dim = setPixelAlpha 0xa0
obscure = setPixelAlpha 0x80
faint = setPixelAlpha 0x40
invisible = setPixelAlpha 0x00
pixelToRGBA (Pixel v) =
let (r,v') = divMod v 0x1000000
(g,v'') = divMod v' 0x10000
(b,a) = divMod v'' 0x100
in (r,g,b,a)
rgbaToPixel (r,g,b,a) = Pixel $ a+0x100*(b+0x100*(g+0x100*r))
opaquify p =
let (r,g,b,a) = pixelToRGBA p
[r',g',b'] = map (\v -> (v*a)`div`0xff) [r,g,b]
in rgbaToPixel (r',g',b',0xff)
black = Pixel 0x01000000
white = Pixel 0xffffff00
orange = Pixel 0xff7f0000
colourWheel :: Int -> Pixel
colourWheel n = Pixel $ (((((r * 0x100) + g) * 0x100) + b) * 0x100) + a
where [r,g,b] = map (\on -> if on then 0xff else 0) $ colourWheel' n
a = 0x00
colourWheel' 0 = [True, False, False]
colourWheel' 1 = [True, True, False]
colourWheel' n = let [a,b,c] = colourWheel' $ n-2 in [c,a,b]
red = colourWheel 0
yellow = colourWheel 1
green = colourWheel 2
cyan = colourWheel 3
blue = colourWheel 4
purple = colourWheel 5
colourOf colouring idx =
case Map.lookup idx colouring of
Nothing -> white
Just n -> colourWheel n
data SVec = SVec { cx, cy :: Int }
deriving (Eq, Ord, Show)
instance Monoid SVec where
mempty = SVec 0 0
mappend (SVec x y) (SVec x' y') = SVec (x+x') (y+y')
instance Grp SVec where
neg (SVec x y) = SVec (-x) (-y)
type CCoord = PHS SVec
hexVec2SVec :: Int -> HexVec -> SVec
hexVec2SVec size (HexVec x y z) =
SVec ((x-z) * size) (-y * 3 * ysize size)
sVec2dHV :: Int -> SVec -> (Double,Double,Double)
sVec2dHV size (SVec sx sy) =
let sx',sy',size' :: Double
[sx',sy',size',ysize'] = map fi [sx,sy,size,ysize size]
y' = -sy' / ysize' / 3
x' = ((sx' / size') - y') / 2
z' = -((sx' / size') + y') / 2
in (x',y',z')
sVec2HexVec :: Int -> SVec -> HexVec
sVec2HexVec size sv =
let (x',y',z') = sVec2dHV size sv
unrounded = Map.fromList [(1,x'),(2,y'),(3,z')]
rounded = Map.map round unrounded
maxdiff = fst $ maximumBy (compare `on` snd) $
[ (i, abs $ c'-c) | i <- [1..3],
let c' = unrounded Map.! i, let c = fi $ rounded Map.! i]
[x,y,z] = map snd $ Map.toList $
Map.adjust (\x -> x - (sum $ Map.elems rounded)) maxdiff rounded
in HexVec x y z
data RenderContext = RenderContext
{ renderSurf :: Surface
, renderBGSurf :: Maybe Surface
, renderHCentre :: HexPos
, renderSCentre :: SVec
, renderSize :: Int
, renderFont :: Maybe TTF.Font
}
type RenderM = ReaderT RenderContext (StateT CachedGlyphs IO)
runRenderM :: RenderM a -> CachedGlyphs -> RenderContext -> IO (a,CachedGlyphs)
runRenderM m cgs rc = runStateT (runReaderT m rc) cgs
displaceRender :: SVec -> RenderM a -> RenderM a
displaceRender disp = local displace
where displace rc = rc { renderSCentre = renderSCentre rc <+> disp }
recentreAt :: HexVec -> RenderM a -> RenderM a
recentreAt v m = do
size <- asks renderSize
displaceRender (hexVec2SVec size v) m
rescaleRender :: RealFrac n => n -> RenderM a -> RenderM a
rescaleRender r = local resize
where resize rc = rc { renderSize = round $ r * (fi $ renderSize rc) }
withFont :: Maybe TTF.Font -> RenderM a -> RenderM a
withFont font = local refont
where refont rc = rc { renderFont = font }
erase :: RenderM ()
erase = fillRectBG Nothing
fillRectBG :: Maybe Rect -> RenderM ()
fillRectBG mrect = do
surf <- asks renderSurf
mbgsurf <- asks renderBGSurf
void $ liftIO $ maybe
(fillRect surf mrect black)
(\bgsurf -> blitSurface bgsurf mrect surf mrect)
mbgsurf
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 $ (0x90 * (maxR - abs (hexLen v)))`div`maxR
in rgbaToPixel (r,g,b,a)
drawAt :: Glyph -> HexPos -> RenderM ()
drawAt gl pos = do
centre <- asks renderHCentre
drawAtRel gl (pos <-> centre)
drawAtRel :: Glyph -> HexVec -> RenderM ()
drawAtRel gl v = do
(surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize
let cpos = scrCentre <+> (hexVec2SVec size v)
renderGlyphCaching gl cpos size surf
messageCol = white
dimWhiteCol = Pixel 0xa0a0a000
buttonTextCol = white
errorCol = red
pixelToColor p =
let (r,g,b,_) = pixelToRGBA p
in Color (fi r) (fi g) (fi b)
renderStrColAtLeft = renderStrColAt' False
renderStrColAt = renderStrColAt' True
renderStrColAt' :: Bool -> Pixel -> String -> HexVec -> RenderM ()
renderStrColAt' centred c str v = void $ runMaybeT $ do
font <- MaybeT $ asks renderFont
fsurf <- MaybeT $ liftIO $ TTF.tryRenderTextBlended font str $ pixelToColor c
(surf, scrCentre, size) <- lift $ asks $
liftM3 (,,) renderSurf renderSCentre renderSize
let SVec x y = scrCentre <+> (hexVec2SVec size v)
<+> neg (SVec 0 ((surfaceGetHeight fsurf-1)`div`2) <+>
if centred
then SVec ((surfaceGetWidth fsurf)`div`2) 0
else SVec 0 0)
void $ liftIO $ blitSurface fsurf Nothing surf (Just $ Rect x y 0 0)
blankRow v = do
(surf, scrCentre, size) <- asks $
liftM3 (,,) renderSurf renderSCentre renderSize
let SVec _ y = scrCentre <+> (hexVec2SVec size v)
w = surfaceGetWidth surf
h = ceiling $ fi (size * 3 `div` 2) * 2 / sqrt 3
fillRectBG $ Just $ Rect 0 (y-h`div`2) w h
drawCursorAt :: Maybe HexPos -> RenderM ()
drawCursorAt (Just pos) = drawAt cursorGlyph pos
drawCursorAt _ = return ()
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 ()
blitAt :: Surface -> HexVec -> RenderM ()
blitAt surface v = do
(surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize
let SVec x y = scrCentre <+> (hexVec2SVec size v)
w = surfaceGetWidth surface
h = surfaceGetHeight surface
void $ liftIO $ blitSurface surface Nothing surf $ Just $
Rect (x-w`div`2) (y-h`div`2) (w+1) (h+1)