summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormbays <>2017-03-26 15:00:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-03-26 15:00:00 (GMT)
commit89336800e3a6befda056a0b403d10b7826e830c4 (patch)
tree9533892928ab8727238a96783be4c0e81857e2e1
parentec88ddbe092e2551ee75bf504c70eacc608d3048 (diff)
version 0.70.7
-rw-r--r--Cache.hs2
-rw-r--r--Command.hs2
-rw-r--r--CursesUI.hs132
-rw-r--r--CursesUIMInstance.hs225
-rw-r--r--Database.hs15
-rw-r--r--Frame.hs1
-rw-r--r--Interact.hs58
-rw-r--r--InteractUtil.hs8
-rw-r--r--KeyBindings.hs25
-rw-r--r--MainState.hs12
-rw-r--r--Metagame.hs2
-rw-r--r--Mundanities.hs6
-rw-r--r--NEWS6
-rw-r--r--Protocol.hs11
-rw-r--r--SDLGlyph.hs371
-rw-r--r--SDLRender.hs753
-rw-r--r--SDLUI.hs8
-rw-r--r--SDLUIMInstance.hs35
-rw-r--r--Server.hs63
-rw-r--r--Version.hs2
-rw-r--r--intricacy.cabal8
21 files changed, 1063 insertions, 682 deletions
diff --git a/Cache.hs b/Cache.hs
index 61a397a..196ac5e 100644
--- a/Cache.hs
+++ b/Cache.hs
@@ -32,7 +32,7 @@ import Mundanities
import ServerAddr
data FetchedRecord = FetchedRecord {fresh :: Bool, fetchError :: Maybe String, fetchedRC :: Maybe RecordContents}
- deriving (Eq, Ord, Show)
+ deriving (Eq, Show)
getRecordCached :: ServerAddr -> Maybe Auth -> Maybe (TVar Bool) -> Bool -> Record -> IO (TVar FetchedRecord)
diff --git a/Command.hs b/Command.hs
index bacb6e6..8db7bd2 100644
--- a/Command.hs
+++ b/Command.hs
@@ -76,7 +76,7 @@ describeCommand CmdWriteState = "write lock"
describeCommand CmdTutorials = "play tutorial levels"
describeCommand CmdShowRetired = "toggle showing retired locks"
describeCommand CmdSetServer = "set server"
-describeCommand CmdToggleCacheOnly = "toggle using only cache"
+describeCommand CmdToggleCacheOnly = "toggle offline mode"
describeCommand (CmdSelCodename mname) = "select player"
++ maybe "" (' ':) mname
describeCommand CmdBackCodename = "select last player"
diff --git a/CursesUI.hs b/CursesUI.hs
index 74a60eb..b5d7f99 100644
--- a/CursesUI.hs
+++ b/CursesUI.hs
@@ -21,6 +21,7 @@ import Data.List
import Control.Monad.Trans.Maybe
import Control.Monad.State
import Data.Function (on)
+import Data.Foldable (forM_)
import Hex
import GameState (stateBoard)
@@ -57,7 +58,7 @@ writeBindings = do
liftIO makeConfDir
liftIO $ writeFile path $ show bdgs
-getBindings :: InputMode -> UIM [(Char, Command)]
+getBindings :: InputMode -> UIM KeyBindings
getBindings mode = do
uibdgs <- Map.findWithDefault [] mode <$> gets uiKeyBindings
return $ uibdgs ++ bindings mode
@@ -69,6 +70,135 @@ bindingsStr mode cmds = do
map (maybe "" showKey . findBinding bdgs) cmds
+data Gravity = GravUp | GravLeft | GravRight | GravDown | GravCentre
+ deriving (Eq, Ord, Show, Enum)
+
+data Draw = Draw { drawWidth :: Int, doDraw :: CVec -> UIM () }
+
+doDrawAt :: CVec -> Draw -> UIM ()
+doDrawAt = flip doDraw
+
+alignDraw :: Gravity -> Int -> Draw -> Draw
+alignDraw gravity w (Draw w' d) = Draw (max w w') $ \(CVec y x) ->
+ d $ CVec y $ x + shift
+ where
+ shift = case gravity of
+ GravLeft -> 0
+ GravRight -> max 0 $ w - w'
+ _ -> max 0 . (`div` 2) $ w - w'
+
+instance Monoid Draw where
+ mempty = Draw 0 (const $ return ())
+ mappend (Draw w d) (Draw w' d') =
+ Draw (w+w') $ \cpos@(CVec y x) -> d cpos >> d' (CVec y (x+w))
+
+stringDraw :: Curses.Attr -> ColPair -> String -> Draw
+stringDraw attr col str =
+ Draw (length str) $ \cpos -> drawStr attr col cpos str
+
+greyDraw :: String -> Draw
+greyDraw = stringDraw a0 white
+
+bindingsDraw :: KeyBindings -> [Command] -> Draw
+bindingsDraw = bindingsDrawColour white
+bindingsDrawColour :: ColPair -> KeyBindings -> [Command] -> Draw
+bindingsDrawColour col bdgs cmds =
+ mconcat . ((stringDraw a0 col "[") :) . (++ [stringDraw a0 col "]"]) .
+ intersperse (stringDraw a0 col ",") $
+ catMaybes $ ((keyDraw <$>) . findBinding bdgs) <$> cmds
+ where
+ keyDraw = stringDraw bold col . showKeyFriendlyShort
+
+data BindingsEntry = BindingsEntry String [Command]
+
+drawBindingsTables :: InputMode -> Frame -> UIM ()
+drawBindingsTables mode frame | mode `elem` [ IMEdit, IMPlay ] = do
+ bdgs <- getBindings mode
+ (h,w) <- liftIO Curses.scrSize
+ let startRight = frameWidth frame + 3
+ let maxWidth = (w `div` 2) - startRight - 1
+ let entryDraws (BindingsEntry desc cmds) =
+ (greyDraw desc, bindingsDraw bdgs cmds)
+ forM_ [GravLeft, GravRight] $ \grav ->
+ let table = bindingsTable mode grav
+ drawsTable = map (\(line, entry) -> (line, entryDraws entry)) table
+ maxDesc = maximum $ map (drawWidth . fst . snd) drawsTable
+ maxBdgs = maximum $ map (drawWidth . snd . snd) drawsTable
+ descX = (w `div` 2) + if grav == GravRight
+ then startRight + maxBdgs + 2
+ else -(startRight + maxBdgs + 2 + maxDesc)
+ bdgsX = (w `div` 2) + if grav == GravRight
+ then startRight
+ else -(startRight + maxBdgs)
+ oppGrav = if grav == GravRight then GravLeft else GravRight
+ useDescs = maxDesc + 1 + maxBdgs <= maxWidth
+ in sequence_
+ [ do
+ when (maxBdgs <= maxWidth) $
+ doDrawAt (CVec y bdgsX) $ alignDraw
+ (if useDescs then grav else oppGrav) maxBdgs
+ bdgsDraw
+ when useDescs $
+ doDrawAt (CVec y descX) $ alignDraw oppGrav maxDesc descDraw
+ | (yoff, (descDraw, bdgsDraw)) <- drawsTable
+ , let y = (h `div` 2) + yoff
+ ]
+ where
+ bindingsTable IMPlay GravLeft =
+ [ (-5, BindingsEntry "move tool" $
+ map (CmdDir WHSSelected) hexDirs)
+ , (-4, BindingsEntry "select tool"
+ [CmdToggle, CmdTile $ WrenchTile zero, CmdTile HookTile])
+ , (-3, BindingsEntry "move hook" $
+ map (CmdDir WHSHook) hexDirs)
+ , (-2, BindingsEntry "move wrench" $
+ map (CmdDir WHSWrench) hexDirs)
+ , (-1, BindingsEntry "rotate hook"
+ [CmdRotate whs dir | whs <- [WHSSelected, WHSHook], dir <- [-1,1]])
+ , ( 0, BindingsEntry "wait" [CmdWait])
+ , ( 2, BindingsEntry "open lock" [CmdOpen])
+ , ( 4, BindingsEntry "undo, redo" [CmdUndo, CmdRedo])
+ , ( 5, BindingsEntry "marks" [CmdMark, CmdJumpMark, CmdReset])
+ ]
+ bindingsTable IMPlay GravRight =
+ [ (-7, BindingsEntry "help" [CmdHelp])
+ , (7, BindingsEntry "quit" [CmdQuit])
+ ]
+ bindingsTable IMEdit GravLeft =
+ [ (-4, BindingsEntry "move" $ map (CmdDir WHSSelected) hexDirs)
+ , (-3, BindingsEntry "rotate"
+ [CmdRotate whs dir | whs <- [WHSSelected], dir <- [-1,1]])
+ , (-1, BindingsEntry "select" [CmdSelect])
+ , ( 0, BindingsEntry "delete" [CmdDelete])
+ , ( 1, BindingsEntry "merge" [CmdMerge])
+ , ( 4, BindingsEntry "undo, redo" [CmdUndo, CmdRedo])
+ , ( 5, BindingsEntry "marks" [CmdMark, CmdJumpMark, CmdReset])
+ ]
+ bindingsTable IMEdit GravRight =
+ [ (-7, BindingsEntry "help" [CmdHelp])
+ , (-4, BindingsEntry "place" $ map CmdTile
+ [ BlockTile []
+ , SpringTile Relaxed zero
+ , PivotTile zero
+ , ArmTile zero False
+ , BallTile
+ ])
+ , (-1, BindingsEntry "test" [CmdTest])
+ , ( 0, BindingsEntry "play" [CmdPlay])
+ , ( 1, BindingsEntry "step" [CmdWait])
+ , ( 4, BindingsEntry "write" [CmdWriteState])
+ , ( 7, BindingsEntry "quit" [CmdQuit])
+ ]
+ bindingsTable _ _ = []
+
+drawBindingsTables _ _ = return ()
+
+-- |frameWidth = maximum . map (abs . cx . hexVec2CVec) .
+-- blockPattern . placedPiece . framePiece
+frameWidth :: Frame -> Int
+frameWidth frame@(BasicFrame size) = max (2*size) $
+ 2*(size + boltWidth frame) - (size`div`2)
+
erase :: UIM ()
erase = liftIO Curses.erase
refresh :: UIM ()
diff --git a/CursesUIMInstance.hs b/CursesUIMInstance.hs
index b10d7f4..086e566 100644
--- a/CursesUIMInstance.hs
+++ b/CursesUIMInstance.hs
@@ -23,6 +23,7 @@ import Data.Map (Map)
import Data.Array
import Data.Maybe
import Data.List
+import Data.Char (chr)
import Control.Monad.Trans.Maybe
import Control.Concurrent (threadDelay)
import Control.Monad.State
@@ -85,8 +86,6 @@ drawNote pos note = case noteBehind note of
drawNameWithChar pos name magenta 'P'
-data Gravity = GravUp | GravLeft | GravRight | GravDown | GravCentre
- deriving (Eq, Ord, Show, Enum)
fillBox :: CVec -> CVec -> Int -> Gravity -> [CVec -> MainStateT UIM ()] -> MainStateT UIM Int
fillBox (CVec t l) (CVec b r) width grav draws = do
let half = width`div`2
@@ -169,27 +168,81 @@ drawLockInfo al@(ActiveLock name i) lockinfo = do
void $ fillBox (CVec (lockBottom+3) (left+1)) (CVec bottom (right-1)) 5 GravUp
[ (`drawActiveLock` al) | al <- map noteOn $ notesSecured lockinfo ]
-drawBasicHelpPage :: (String,ColPair) -> ([String],ColPair) -> UIM ()
-drawBasicHelpPage (title,titleCol) (body,bodyCol) = do
+
+data HelpReturn = HelpNone | HelpDone | HelpContinue Int
+
+showHelpPaged :: Int -> InputMode -> HelpPage -> UIM Bool
+showHelpPaged from mode page =
+ showHelpPaged' from mode page >>= \ret -> case ret of
+ HelpNone -> return False
+ HelpDone -> return True
+ HelpContinue from' -> do
+ drawPrompt False "[MORE]"
+ getInput IMTextInput
+ showHelpPaged from' mode page
+showHelpPaged' :: Int -> InputMode -> HelpPage -> UIM HelpReturn
+showHelpPaged' from mode HelpPageInput = do
+ bdgs <- nub <$> getBindings mode
+ erase
+ (h,w) <- liftIO Curses.scrSize
+ let bdgWidth = 39
+ showKeys chs = intercalate "/" (map showKey chs)
+ maxkeyslen = maximum $ map (length.showKeys.map fst) $ groupBy ((==) `on` snd) bdgs
+ drawStrCentred a0 cyan (CVec 0 (w`div`2)) "Bindings:"
+ let groups = filter (not . null . describeCommand . snd . head) $
+ drop from $ groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs
+ let draws =
+ [ drawStr a0 cyan (CVec (y+2) (x*bdgWidth) ) $
+ keysStr ++ replicate pad ' ' ++ ": " ++ desc
+ | ((keysStr,pad,desc),(x,y)) <- zip
+ [ (keysStr,pad,desc)
+ | group <- groups
+ , let cmd = snd $ head group
+ , let desc = describeCommand cmd
+ , let chs = map fst group
+ , let keysStr = showKeys chs
+ , let pad = max 0 $ minimum [maxkeyslen + 1 - length keysStr,
+ bdgWidth - length desc - length keysStr - 1 - 1]
+ ]
+ (map (`divMod` (h-3)) [0..])
+ , (x+1)*bdgWidth < w]
+ sequence_ draws
+ refresh
+ return $ if length draws < length groups
+ then HelpContinue $ from + length draws
+ else HelpDone
+showHelpPaged' from IMMeta HelpPageGame =
+ drawBasicHelpPage from ("INTRICACY",magenta) (metagameHelpText,magenta)
+showHelpPaged' from IMEdit HelpPageFirstEdit =
+ drawBasicHelpPage from ("Your first lock:",magenta) (firstEditHelpText,green)
+showHelpPaged' _ _ _ = return HelpNone
+
+drawBasicHelpPage :: Int -> (String,ColPair) -> ([String],ColPair) -> UIM HelpReturn
+drawBasicHelpPage from (title,titleCol) (body,bodyCol) = do
erase
(h,w) <- liftIO Curses.scrSize
drawStrCentred a0 titleCol (CVec 0 $ w`div`2) title
- if w >= maximum (map length metagameHelpText)
- then sequence_ [drawStrCentred a0 bodyCol (CVec line $ w`div`2) str |
- (line,str) <- zip [2..h] $ body ]
- else do
- let wrap max = wrap' max max
- wrap' _ _ [] = []
- wrap' max left (w:ws) = if 1+length w > left
- then if left == max
- then take max w ++ "\n" ++
- wrap' max max (drop max w : ws)
- else '\n' : wrap' max max (w:ws)
- else let prepend = if left == max then w else ' ':w
- in prepend ++ wrap' max (left - length prepend) ws
- sequence_ [drawStrCentred a0 bodyCol (CVec line $ w`div`2) str |
- (line,str) <- zip [1..h] $
- lines (wrap w $ words $ intercalate " " body) ]
+ let strs = drop from $
+ if w >= maximum (map length metagameHelpText)
+ then body
+ else
+ let wrap max = wrap' max max
+ wrap' _ _ [] = []
+ wrap' max left (w:ws) = if 1+length w > left
+ then if left == max
+ then take max w ++ "\n" ++
+ wrap' max max (drop max w : ws)
+ else '\n' : wrap' max max (w:ws)
+ else let prepend = if left == max then w else ' ':w
+ in prepend ++ wrap' max (left - length prepend) ws
+ in lines . wrap w . words $ intercalate " " body
+ let draws = [drawStrCentred a0 bodyCol (CVec y $ w`div`2) str |
+ (y,str) <- zip [2..h-2] $ strs ]
+ sequence_ draws
+ return $ if length draws < length strs
+ then HelpContinue $ from + length draws
+ else HelpDone
+
charify :: Curses.Key -> Maybe Char
charify key = case key of
@@ -205,6 +258,14 @@ charify key = case key of
Curses.KeyEnd -> Just '1'
_ -> Nothing
+handleEsc k@(Curses.KeyChar '\ESC') = do
+ Curses.timeout 100
+ cch <- Curses.getch
+ Curses.timeout (-1)
+ return $ if cch == -1 then k
+ else Curses.KeyChar $ chr $ fi cch+128
+handleEsc k = return k
+
instance UIMonad (StateT UIState IO) where
runUI m = evalStateT m nullUIState
@@ -216,16 +277,20 @@ instance UIMonad (StateT UIState IO) where
drawMainState' s
lift refresh
where
- drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts, wrenchSelected=wsel }) = lift $ do
+ drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts,
+ wrenchSelected=wsel, psFrame=frame }) = lift $ do
drawState [] False alerts st
+ drawBindingsTables IMPlay frame
drawCursorAt $ listToMaybe [ pos |
(_, PlacedPiece pos p) <- enumVec $ placedPieces st
, or [wsel && isWrench p, not wsel && isHook p] ]
drawMainState' (ReplayState {}) = do
lift . drawState [] False [] =<< gets rsCurrentState
lift $ drawCursorAt Nothing
- drawMainState' (EditState { esGameStateStack=(st:_), selectedPiece=selPiece, selectedPos=selPos }) = lift $ do
+ drawMainState' (EditState { esGameStateStack=(st:_), selectedPiece=selPiece,
+ selectedPos=selPos, esFrame=frame }) = lift $ do
drawState (maybeToList selPiece) True [] st
+ drawBindingsTables IMEdit frame
drawCursorAt $ if isNothing selPiece then Just selPos else Nothing
drawMainState' (MetaState {curServer=saddr, undeclareds=undecls,
cacheOnly=cOnly, curAuth=auth, codenameStack=names,
@@ -236,22 +301,28 @@ instance UIMonad (StateT UIState IO) where
let home = isJust ourName && ourName == selName
(h,w) <- liftIO Curses.scrSize
when (h<20 || w<40) $ liftIO CursesH.end >> error "Terminal too small!"
+ bdgs <- lift $ getBindings IMMeta
lift $ do
drawCursorAt Nothing
- sstr <- (++" Server: ") <$> bindingsStr IMMeta [CmdSetServer, CmdToggleCacheOnly]
- hstr <- (\[ks,ts] -> ts++" tut "++ks++" keys") <$>
- bindingsStr IMMeta `mapM` [[CmdHelp],[CmdTutorials]]
- drawStrGrey (CVec 0 0) $ sstr ++
- take (w - length sstr - length hstr)
- (saddrStr saddr ++ (if cOnly then " (cache only) " else "") ++ repeat ' ') ++
- hstr
- drawStrGrey (CVec 1 0) =<<
- (\[es,ls] -> take 5 (es ++ repeat ' ') ++ " Lock: " ++ path ++ " " ++ ls) <$>
- bindingsStr IMMeta `mapM`
- [ [CmdEdit] ++ if path == "" then [] else [CmdPlaceLock Nothing]
- , [CmdSelectLock] ++ if path == "" then [] else [CmdNextLock, CmdPrevLock]
- ]
- lift $ drawStrGrey (CVec 2 (maximum [w`div`3+1, w`div`2 - 13])) =<< bindingsStr IMMeta [CmdSelCodename Nothing]
+ let serverBdgsDraw = bindingsDraw bdgs
+ [CmdSetServer, CmdToggleCacheOnly]
+ lockBdgsDraw = bindingsDraw bdgs $
+ [CmdEdit] ++ if path == "" then [] else [CmdPlaceLock Nothing]
+ leftBdgsWidth = (+3) . maximum $ map drawWidth [serverBdgsDraw, lockBdgsDraw]
+ helpDraw = bindingsDraw bdgs [CmdTutorials] <> greyDraw " tutorial " <>
+ bindingsDraw bdgs [CmdHelp] <> greyDraw " help"
+ serverTextDraw = greyDraw . take (w - leftBdgsWidth - drawWidth helpDraw - 1) $
+ " Server: " ++ saddrStr saddr ++ (if cOnly then " (offline mode) " else "")
+ lockBdgsDraw' = bindingsDraw bdgs $
+ [CmdSelectLock] ++ if path == "" then [] else [CmdNextLock, CmdPrevLock]
+ lockTextDraw = greyDraw . take (w - leftBdgsWidth - drawWidth lockBdgsDraw' - 1) $
+ " Lock: " ++ path ++ replicate 5 ' '
+ doDrawAt (CVec 0 0) $ alignDraw GravLeft leftBdgsWidth serverBdgsDraw <> serverTextDraw
+ doDrawAt (CVec 0 0) $ alignDraw GravRight w helpDraw
+ doDrawAt (CVec 1 0) $ alignDraw GravLeft leftBdgsWidth lockBdgsDraw <> lockTextDraw <> lockBdgsDraw'
+
+ doDrawAt (CVec 2 $ maximum [w`div`3+1, w`div`2 - 13]) $ bindingsDraw bdgs [CmdSelCodename Nothing]
+
maybe (return ()) (drawName True (CVec 2 (w`div`2))) selName
void.runMaybeT $ MaybeT (return selName) >>= lift . getUInfoFetched 300 >>=
\(FetchedRecord fresh err muirc) -> lift $ do
@@ -259,33 +330,48 @@ instance UIMonad (StateT UIState IO) where
unless fresh $ drawAtCVec (Glyph '*' red bold) $ CVec 2 (w`div`2+7)
maybe (return ()) sayError err
when (fresh && (isNothing ourName || home || isNothing muirc)) $
- drawStrGrey (CVec 2 (w`div`2+1+9)) =<<
- (bindingsStr IMMeta $
- if (isNothing muirc && isNothing ourName) || home then [CmdRegister $ isJust ourName] else [CmdAuth])
+ doDrawAt (CVec 2 (w`div`2+1+9)) $
+ bindingsDraw bdgs $
+ if (isNothing muirc && isNothing ourName) || home
+ then [CmdRegister $ isJust ourName] else [CmdAuth]
for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of
Just retired -> do
(h,w) <- liftIO Curses.scrSize
void $ fillBox (CVec 6 2) (CVec (h-1) (w-2)) 5 GravCentre
[ \pos -> lift $ drawStrGrey pos $ show ls | ls <- retired ]
- lift $ drawStrGrey (CVec 5 (w`div`3)) =<< bindingsStr IMMeta
- ([CmdShowRetired] ++ if null retired then [] else [CmdPlayLockSpec Nothing])
+ lift $ doDrawAt (CVec 5 (w`div`3)) $ bindingsDraw bdgs $
+ [CmdShowRetired] ++ if null retired
+ then [] else [CmdPlayLockSpec Nothing]
Nothing -> do
sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) lockinfo |
(i,Just lockinfo) <- assocs $ userLocks uinfo ]
unless (null $ elems $ userLocks uinfo) $ lift $
- drawStrGrey (CVec 5 (w`div`3)) =<< bindingsStr IMMeta [CmdSolve Nothing, CmdViewSolution Nothing]
+ doDrawAt (CVec 5 (w`div`3)) $ bindingsDraw bdgs $
+ [CmdSolve Nothing] ++ if isJust ourName then [CmdViewSolution Nothing] else []
when (isJust ourName && ourName == selName) $ do
- unless (null undecls) $ do
- str <- lift $ (++" Undeclared solutions:") <$> bindingsStr IMMeta [CmdDeclare Nothing]
- let s = max 1 $ (w-(length str + 6*length undecls))`div`2
- let y = 4
- lift $ drawStr bold white (CVec y s) str
- void $ fillBox (CVec y (s+length str+1)) (CVec y (w-1)) 5 GravLeft
- [ (`drawActiveLock` al) | Undeclared _ _ al <- undecls ]
rnames <- liftIO $ atomically $ readTVar rnamestvar
unless (null rnames) $
- void $ fillBox (CVec 2 5) (CVec 5 (w`div`3)) 3 GravCentre
+ void $ fillBox (CVec 2 0) (CVec 5 (w`div`3)) 3 GravCentre
[ \pos -> drawName False pos name | name <- rnames ]
+ unless (null undecls) $
+ let declareBdgDraw = bindingsDraw bdgs [CmdDeclare Nothing]
+ declareText = " Undeclared solutions:"
+ y = 4
+ leftBound = w`div`3 + 1
+ undeclsWidth = 1 + 6 * length undecls
+ declareDraw =
+ if leftBound + drawWidth declareBdgDraw + length declareText + undeclsWidth >= w
+ then declareBdgDraw
+ else declareBdgDraw <> stringDraw bold white declareText
+ width = drawWidth declareDraw + undeclsWidth
+ left = max leftBound ((w - width) `div` 2)
+ in do
+ lift $ doDrawAt (CVec y left) declareDraw
+ void $ fillBox
+ (CVec y $ left + drawWidth declareDraw + 1)
+ (CVec y (w-1)) 5 GravLeft
+ [ (`drawActiveLock` al) | Undeclared _ _ al <- undecls ]
+
when (ourName /= selName) $ void $ runMaybeT $ do
sel <- liftMaybe selName
us <- liftMaybe ourName
@@ -319,39 +405,9 @@ instance UIMonad (StateT UIState IO) where
endPrompt = say "" >> (liftIO $ void $ Curses.cursSet Curses.CursorInvisible)
drawError = sayError
- showHelp mode HelpPageInput = do
- bdgs <- nub <$> getBindings mode
- erase
- (h,w) <- liftIO Curses.scrSize
- let bdgWidth = 35
- showKeys chs = intercalate "/" (map showKey chs)
- maxkeyslen = maximum $ map (length.showKeys.map fst) $ groupBy ((==) `on` snd) bdgs
- drawStrCentred a0 cyan (CVec 0 (w`div`2)) "Bindings:"
- sequence_ [ drawStr a0 cyan (CVec (y+2) (x*bdgWidth) ) $
- keysStr ++ replicate pad ' ' ++ ": " ++ desc |
- ((keysStr,pad,desc),(x,y)) <- zip [(keysStr,pad,desc)
- | group <- groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs
- , let cmd = snd $ head group
- , let desc = describeCommand cmd
- , not $ null desc
- , let chs = map fst group
- , let keysStr = showKeys chs
- , let pad = max 0 $ minimum [maxkeyslen + 1 - length keysStr,
- bdgWidth - length desc - length keysStr - 1]
- ]
- (map (`divMod` (h-3)) [0..])
- , (x+1)*bdgWidth < w]
- refresh
- return True
- showHelp IMMeta HelpPageGame = do
- drawBasicHelpPage ("INTRICACY",magenta) (metagameHelpText,magenta)
- return True
- showHelp IMEdit HelpPageFirstEdit = do
- drawBasicHelpPage ("Your first lock:",magenta) (firstEditHelpText,green)
- return True
- showHelp _ _ = return False
-
- getChRaw = (charify<$>) $ liftIO $ CursesH.getKey (return ())
+ showHelp = showHelpPaged 0
+
+ getChRaw = (charify<$>) $ liftIO $ CursesH.getKey (return ()) >>= handleEsc
setUIBinding mode cmd ch =
modify $ \s -> s { uiKeyBindings =
Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs)
@@ -398,7 +454,8 @@ instance UIMonad (StateT UIState IO) where
getInput mode = do
let userResizeCode = 1337 -- XXX: chosen not to conflict with HSCurses codes
- key <- liftIO $ CursesH.getKey (Curses.ungetCh userResizeCode)
+ key <- liftIO $ CursesH.getKey (Curses.ungetCh userResizeCode) >>=
+ handleEsc
if key == Curses.KeyUnknown userResizeCode
then do
liftIO Curses.scrSize
diff --git a/Database.hs b/Database.hs
index 36a1283..2ed54f1 100644
--- a/Database.hs
+++ b/Database.hs
@@ -23,6 +23,7 @@ import qualified Data.ByteString.Lazy.Char8 as CL
import qualified Data.ByteString.Char8 as CS
import Crypto.Hash (hashlazy, Digest, SHA1, digestToHexByteString)
+import Crypto.Types.PubKey.RSA (PublicKey, PrivateKey)
import Protocol
import Metagame
@@ -46,6 +47,8 @@ data Record
| RecRetiredLocks Codename
| RecServerInfo
| RecServerEmail
+ | RecPublicKey
+ | RecSecretKey
deriving (Eq, Ord, Show)
data RecordContents
= RCPassword Password
@@ -57,13 +60,16 @@ data RecordContents
| RCLockSpecs [LockSpec]
| RCServerInfo ServerInfo
| RCEmail CS.ByteString
- deriving (Eq, Ord, Show)
+ | RCPublicKey PublicKey
+ | RCSecretKey PrivateKey
+ deriving (Eq, Show)
rcOfServerResp (ServedServerInfo x) = RCServerInfo x
rcOfServerResp (ServedLock x) = RCLock x
rcOfServerResp (ServedSolution x) = RCSolution x
rcOfServerResp (ServedUserInfo x) = RCUserInfo x
rcOfServerResp (ServedRetired x) = RCLockSpecs x
+rcOfServerResp (ServedPublicKey x) = RCPublicKey x
rcOfServerResp _ = error "no corresponding rc"
invariantRecord (RecUserInfo _) = False
@@ -79,6 +85,7 @@ askForRecord (RecUserInfo name) = GetUserInfo name Nothing
askForRecord (RecLock ls) = GetLock ls
askForRecord (RecNote note) = GetSolution note
askForRecord (RecRetiredLocks name) = GetRetired name
+askForRecord RecPublicKey = GetPublicKey
askForRecord _ = error "no corresponding request"
type DBM = ReaderT FilePath IO
@@ -104,6 +111,8 @@ getRecordh RecLockHashes h = ((RCLockHashes <$>) . tryRead) <$> hGetStrict h
getRecordh (RecRetiredLocks name) h = ((RCLockSpecs <$>) . tryRead) <$> hGetStrict h
getRecordh RecServerInfo h = ((RCServerInfo <$>) . tryRead) <$> hGetStrict h
getRecordh RecServerEmail h = ((RCEmail <$>) . tryRead) <$> hGetStrict h
+getRecordh RecPublicKey h = ((RCPublicKey <$>) . tryRead) <$> hGetStrict h
+getRecordh RecSecretKey h = ((RCSecretKey <$>) . tryRead) <$> hGetStrict h
hGetStrict h = CS.unpack <$> concatMWhileNonempty (repeat $ CS.hGet h 1024)
where concatMWhileNonempty (m:ms) = do
@@ -129,6 +138,8 @@ putRecordh (RCSolution solution) h = hPutStr h $ show solution
putRecordh (RCLockHashes hashes) h = hPutStr h $ show hashes
putRecordh (RCLockSpecs lss) h = hPutStr h $ show lss
putRecordh (RCServerInfo sinfo) h = hPutStr h $ show sinfo
+putRecordh (RCPublicKey publicKey) h = hPutStr h $ show publicKey
+putRecordh (RCSecretKey secretKey) h = hPutStr h $ show secretKey
modifyRecord :: Record -> (RecordContents -> RecordContents) -> DBM ()
modifyRecord rec f = do
@@ -177,6 +188,8 @@ recordPath rec =
recordPath' RecLockHashes = "lockHashes"
recordPath' RecServerInfo = "serverInfo"
recordPath' RecServerEmail = "serverEmail"
+ recordPath' RecPublicKey = "publicKey"
+ recordPath' RecSecretKey = "secretKey"
userDir name = "users" ++ [pathSeparator] ++ pathifyName name ++ [pathSeparator]
alockFN (ActiveLock name idx) = pathifyName name ++":"++ show idx
diff --git a/Frame.hs b/Frame.hs
index 4687af1..174d030 100644
--- a/Frame.hs
+++ b/Frame.hs
@@ -30,7 +30,6 @@ entrance f = neg $ bolthole f
boltWidth :: Frame -> Int
boltWidth (BasicFrame size) = size`div`4+1
-
baseState :: Frame -> GameState
baseState f =
GameState
diff --git a/Interact.hs b/Interact.hs
index fa89283..2ba2fcc 100644
--- a/Interact.hs
+++ b/Interact.hs
@@ -8,6 +8,8 @@
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see http://www.gnu.org/licenses/.
+{-# LANGUAGE ScopedTypeVariables #-}
+
module Interact (interactUI) where
import Control.Monad.State
@@ -18,6 +20,7 @@ import Data.Map (Map)
import Control.Monad.Writer
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
+import Control.Exception
import Data.Maybe
import Data.Char
import Data.List
@@ -28,6 +31,12 @@ import System.FilePath
import Data.Array
import Data.Function (on)
import Safe (readMay)
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Char8 as CS
+
+import Crypto.Types.PubKey.RSA (PublicKey)
+import Codec.Crypto.RSA (encrypt)
+import Crypto.Random (newGenIO, SystemRandom)
import Hex
import Command
@@ -214,24 +223,23 @@ processCommand' IMMeta CmdSetServer = void.runMaybeT $ do
liftIO $ atomically $ writeTVar rnamestvar []
invalidateAllUInfo
refreshUInfoUI
-processCommand' IMMeta CmdToggleCacheOnly =
- not <$> gets cacheOnly >>= \c -> modify $ \ms -> ms {cacheOnly = c}
+processCommand' IMMeta CmdToggleCacheOnly = do
+ newCOnly <- gets $ not . cacheOnly
+ modify $ \ms -> ms {cacheOnly = newCOnly}
+ unless newCOnly $
+ invalidateAllUInfo >> invalidateAllIndexedLocks
processCommand' IMMeta (CmdRegister _) = void.runMaybeT $ do
regName <- mgetCurName
mauth <- gets curAuth
let isUs = maybe False ((==regName).authUser) mauth
- let inputPassword = do
- pw <- MaybeT $ lift $ textInput "Enter new password:" 64 True False Nothing Nothing
- guard $ not $ null pw
- return $ hashPassword regName pw
if isUs
then msum [ do
confirmOrBail "Log out?"
modify $ \ms -> ms {curAuth = Nothing}
, do
confirmOrBail "Reset password?"
- passwd <- inputPassword
+ passwd <- inputPassword regName "Enter new password:"
lift $ do
resp <- curServerAction $ ResetPassword passwd
case resp of
@@ -245,7 +253,7 @@ processCommand' IMMeta (CmdRegister _) = void.runMaybeT $ do
setNotifications
]
else do
- passwd <- inputPassword
+ passwd <- inputPassword regName "Enter new password:"
lift $ do
modify $ \ms -> ms {curAuth = Just $ Auth regName passwd}
resp <- curServerAction Register
@@ -277,8 +285,7 @@ processCommand' IMMeta CmdAuth = void.runMaybeT $ do
modify $ \ms -> ms {curAuth = Nothing}
else do
name <- mgetCurName
- passwd <- (hashPassword name <$>) $ MaybeT $ lift $
- textInput ("Enter password for "++name++":") 64 True False Nothing Nothing
+ passwd <- inputPassword name $ "Enter password for "++name++":"
lift $ do
modify $ \ms -> ms {curAuth = Just $ Auth name passwd}
resp <- curServerAction $ Authenticate
@@ -661,7 +668,7 @@ processCommand' IMEdit (CmdPaint tile) = do
drawTile selPos tile True
processCommand' IMEdit (CmdPaintFromTo tile from to) = do
frame <- gets esFrame
- paintTilePath tile (truncateToEditable frame from) (truncateToEditable frame to)
+ paintTilePath frame tile (truncateToEditable frame from) (truncateToEditable frame to)
processCommand' IMEdit CmdMerge = do
selPos <- gets selectedPos
st:_ <- gets esGameStateStack
@@ -712,9 +719,32 @@ processCommand' IMEdit CmdWriteState = void.runMaybeT $ do
Just err -> lift $ drawError $ "Write failed: "++err
processCommand' _ _ = return ()
-hashPassword :: String -> String -> String
--- ^ salt password
-hashPassword name password = hash $ "IY" ++ name ++ password
+inputPassword :: UIMonad uiM => Codename -> String -> MaybeT (MainStateT uiM) String
+inputPassword name prompt = do
+ pw <- MaybeT $ lift $ textInput prompt 64 True False Nothing Nothing
+ guard $ not $ null pw
+ RCPublicKey publicKey <- MaybeT $ getFreshRecBlocking RecPublicKey
+ encryptPassword publicKey name pw
+
+-- | Salt and encrypt a password, to protect users' passwords from sniffing
+-- and dictionary attack. We can hope that they wouldn't use valuable
+-- passwords, but we shouldn't assume it.
+-- Note that in all other respects, the protocol is entirely insecure -
+-- nothing else is encrypted, and anyone sniffing an encrypted password can
+-- replay it to authenticate as the user.
+encryptPassword :: UIMonad uiM =>
+ PublicKey -> String -> String -> MaybeT (MainStateT uiM) String
+encryptPassword publicKey name password = msum
+ [ MaybeT . liftIO .
+ handle (\(e :: SomeException) -> return Nothing) $ do
+ g <- newGenIO :: IO SystemRandom
+ return . Just . CS.unpack . BL.toStrict . fst . encrypt g publicKey .
+ BL.fromStrict . CS.pack $ hashed
+ , confirmOrBail
+ "Failed to encrypt password - send unencrypted?"
+ >> return hashed
+ ]
+ where hashed = hash $ "IY" ++ name ++ password
setSelectedPosFromMouse :: UIMonad uiM => MainStateT uiM ()
setSelectedPosFromMouse = lift getUIMousePos >>= maybe (return ()) setSelectedPos
diff --git a/InteractUtil.hs b/InteractUtil.hs
index f8d0fa5..ee66f1b 100644
--- a/InteractUtil.hs
+++ b/InteractUtil.hs
@@ -60,10 +60,12 @@ drawTile pos tile painting = do
lastMP <- gets lastModPos
modifyEState $ modTile tile pos lastMP painting
modify $ \es -> es {lastModPos = pos}
-paintTilePath tile from to = if from == to
+paintTilePath frame tile from to = if from == to
then modify $ \es -> es {lastModPos = to}
- else let from' = (hexVec2HexDirOrZero $ to-^from) +^ from
- in drawTile from' tile True >> paintTilePath tile from' to
+ else do
+ let from' = (hexVec2HexDirOrZero $ to-^from) +^ from
+ when (inEditable frame from') $ drawTile from' tile True
+ paintTilePath frame tile from' to
pushEState :: UIMonad uiM => GameState -> MainStateT uiM ()
pushEState st = do
diff --git a/KeyBindings.hs b/KeyBindings.hs
index 2b64535..2e347d7 100644
--- a/KeyBindings.hs
+++ b/KeyBindings.hs
@@ -8,11 +8,13 @@
-- 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 KeyBindings (KeyBindings, bindings, findBindings, findBinding, showKey, showKeyFriendly) where
+module KeyBindings (KeyBindings, bindings, findBindings, findBinding, showKey,
+ showKeyFriendly, showKeyFriendlyShort) where
import Data.Maybe
import Data.Char
import Data.List
+import Data.Bits (xor)
import Command
import Hex
@@ -21,9 +23,11 @@ import InputMode
type KeyBindings = [ (Char,Command) ]
-ctrl, unctrl :: Char -> Char
-ctrl c = toEnum $ fromEnum c - 64
-unctrl c = toEnum $ fromEnum c + 64
+ctrl, unctrl, meta, unmeta :: Char -> Char
+ctrl = toEnum . xor 64 . fromEnum
+meta = toEnum . xor 128 . fromEnum
+unctrl = ctrl
+unmeta = meta
lowerToo :: KeyBindings -> KeyBindings
lowerToo = concat . map addLower
@@ -207,9 +211,11 @@ findBindings bdgs cmd = nub
findBinding :: KeyBindings -> Command -> Maybe Char
findBinding = (listToMaybe.) . findBindings
-showKey ch | isPrint ch = [ch]
-showKey ch | isPrint (unctrl ch) = ('^':[unctrl ch])
-showKey _ = "[?]"
+showKey ch
+ | isAscii (unmeta ch) = 'M':'-':showKey (unmeta ch)
+ | isPrint ch = [ch]
+ | isPrint (unctrl ch) = ('^':[unctrl ch])
+ | otherwise = "[?]"
showKeyFriendly ' ' = "space"
showKeyFriendly '\r' = "return"
@@ -217,3 +223,8 @@ showKeyFriendly '\n' = "newline"
showKeyFriendly '\t' = "tab"
showKeyFriendly '\b' = "bksp"
showKeyFriendly ch = showKey ch
+
+showKeyFriendlyShort '\r' = "ret"
+showKeyFriendlyShort '\t' = "tab"
+showKeyFriendlyShort '\b' = "bksp"
+showKeyFriendlyShort ch = showKey ch
diff --git a/MainState.hs b/MainState.hs
index 56d455a..b597a4a 100644
--- a/MainState.hs
+++ b/MainState.hs
@@ -289,6 +289,10 @@ mgetLock ls = do
RCLock lock <- MaybeT $ (fetchedRC<$>) $ liftIO $ atomically $ readTVar tvar
return $ reframe lock
+invalidateAllIndexedLocks :: UIMonad uiM => MainStateT uiM ()
+invalidateAllIndexedLocks =
+ modify $ \ms -> ms { indexedLocks = Map.empty }
+
refreshUInfoUI :: (UIMonad uiM) => MainStateT uiM ()
refreshUInfoUI = void.runMaybeT $ do
modify $ \ms -> ms { listOffset = 0 }
@@ -450,10 +454,10 @@ testAuth = isJust <$> gets curAuth >>? do
metagameHelpText :: [String]
metagameHelpText =
- [ "By ruthlessly guarded secret arrangement, the Council's agents can pick any lock in the city."
- , "The Guild produces the necessary locks - apparently secure, but with fatal hidden flaws."
+ [ "By ruthlessly guarded secret arrangement, the council's agents can pick any lock in the city."
+ , "A secret guild produces the necessary locks - apparently secure, but with fatal hidden flaws."
, "A ritual game is played to determine the best designs."
- , "To play the game well, you must build locks which can be picked only by one who knows the secret,"
+ , "To master it, you must build locks which can be picked only by one who knows the secret,"
, "and you must discover the secret flaws in the locks designed by your colleagues."
, ""
, "You may put forward up to three prototype locks. They will guard the secrets you discover."
@@ -477,7 +481,7 @@ metagameHelpText =
firstEditHelpText :: [String]
firstEditHelpText =
[ "Design a lock to protect your secrets."
- , "It must be possible to solve your lock by pulling a sprung bolt from the hole in the top-right,"
+ , "It must be possible to pick your lock by pulling a sprung bolt from the hole in the top-right,"
, "but you should place blocks, springs, pivots, and balls to make this as difficult as possible."
, ""
, "Place pieces with keyboard or mouse. Springs must be set next to blocks, and arms next to pivots."
diff --git a/Metagame.hs b/Metagame.hs
index e4050fc..79cedac 100644
--- a/Metagame.hs
+++ b/Metagame.hs
@@ -126,7 +126,7 @@ applyLockDelta (AddSecured n) lockinfo = lockinfo { notesSecured = n:(notesSecur
applyLockDelta (DelSecured n) lockinfo = lockinfo { notesSecured = delete n $ notesSecured lockinfo }
applyLockDelta (AddSolution n) lockinfo = lockinfo { lockSolutions = n:(lockSolutions lockinfo) }
applyLockDelta (AddAccessed name) lockinfo = lockinfo { accessedBy = name:(delete name $ accessedBy lockinfo) }
-applyLockDelta SetPublic lockinfo = lockinfo { public = True, lockSolutions = [], accessedBy = []}
+applyLockDelta SetPublic lockinfo = lockinfo { public = True, lockSolutions = [], accessedBy = [], notesSecured = []}
instance Binary UserInfo where
put (UserInfo name locks notes) = put name >> put locks >> put notes
diff --git a/Mundanities.hs b/Mundanities.hs
index 0ca22db..64b9ff9 100644
--- a/Mundanities.hs
+++ b/Mundanities.hs
@@ -14,6 +14,7 @@ import Control.Arrow
import Control.Monad
import qualified Control.Exception as E
import System.Directory
+import System.Environment (getEnv)
import System.FilePath
import Data.Maybe
import Data.List
@@ -50,8 +51,9 @@ writeStrings file x = do
BS.writeFile file $ BSC.pack $ unlines x
confFilePath :: FilePath -> IO FilePath
-confFilePath str =
- (++(pathSeparator:str)) <$> getAppUserDataDirectory "intricacy"
+confFilePath str = (++(pathSeparator:str)) <$>
+ catchIO (getEnv "INTRICACY_PATH")
+ (const $ getAppUserDataDirectory "intricacy")
getDataPath :: FilePath -> IO FilePath
getDataPath = getDataFileName
diff --git a/NEWS b/NEWS
index fbfa324..3a6bc00 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,11 @@
This is an abbreviated summary; see the git log for gory details.
+0.7:
+ Encrypt passwords when communicating with server
+ (in previous versions, they were salted and hashed but not encrypted).
+ Clean out solutions when a lock becomes public.
+ Various UI improvements, particularly for curses mode.
+
0.6.2:
Fix obscure but actual bug in core game physics:
wrenches were being blocked when they shouldn't be.
diff --git a/Protocol.hs b/Protocol.hs
index e9976c5..c57a85f 100644
--- a/Protocol.hs
+++ b/Protocol.hs
@@ -13,6 +13,8 @@ module Protocol where
import Data.Binary
import Control.Monad
+import Crypto.Types.PubKey.RSA (PublicKey)
+
import BinaryInstances
import Metagame
import Lock
@@ -31,6 +33,7 @@ data Action
| ResetPassword Password
| SetEmail String
| GetServerInfo
+ | GetPublicKey
| GetLock LockSpec
| GetRetired Codename
| GetUserInfo Codename (Maybe Int)
@@ -48,6 +51,7 @@ type Password = String
needsAuth :: Action -> Bool
needsAuth GetServerInfo = False
+needsAuth GetPublicKey = False
needsAuth (GetLock _) = False
needsAuth (GetUserInfo _ _) = False
needsAuth (GetRetired _) = False
@@ -59,6 +63,7 @@ data ServerResponse
| ServerMessage String
| ServerError String
| ServedServerInfo ServerInfo
+ | ServedPublicKey PublicKey
| ServedLock Lock
| ServedRetired [LockSpec]
| ServedUserInfo VersionedUInfo
@@ -69,7 +74,7 @@ data ServerResponse
| ServerCodenameFree
| ServerFresh
| ServerUndefinedResponse
- deriving (Eq, Ord, Show, Read)
+ deriving (Eq, Show, Read)
data ServerInfo = ServerInfo {serverLockSize :: Int, serverInfoString::String}
deriving (Eq, Ord, Show, Read)
@@ -93,6 +98,7 @@ instance Binary Action where
put (ResetPassword pw) = put (10::Word8) >> put pw
put (GetRetired name) = put (11::Word8) >> put name
put (SetEmail address) = put (12::Word8) >> put address
+ put GetPublicKey = put (13::Word8)
get = do
tag <- get :: Get Word8
case tag of
@@ -109,6 +115,7 @@ instance Binary Action where
10 -> liftM ResetPassword get
11 -> liftM GetRetired get
12 -> liftM SetEmail get
+ 13 -> return GetPublicKey
_ -> return UndefinedAction
instance Binary Auth where
@@ -129,6 +136,7 @@ instance Binary ServerResponse where
put (ServerCodenameFree) = put (10::Word8)
put (ServerFresh) = put (11::Word8)
put (ServedRetired lss) = put (12::Word8) >> put lss
+ put (ServedPublicKey publicKey) = put (13::Word8) >> put (show publicKey)
get = do
tag <- get :: Get Word8
case tag of
@@ -145,6 +153,7 @@ instance Binary ServerResponse where
10 -> return ServerCodenameFree
11 -> return ServerFresh
12 -> liftM ServedRetired get
+ 13 -> liftM (ServedPublicKey . read) get
_ -> return ServerUndefinedResponse
instance Binary ServerInfo where
put (ServerInfo sz str) = put sz >> put str
diff --git a/SDLGlyph.hs b/SDLGlyph.hs
new file mode 100644
index 0000000..0ac9cf2
--- /dev/null
+++ b/SDLGlyph.hs
@@ -0,0 +1,371 @@
+-- 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
+ | 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
+
+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 = do
+ size <- asks renderSize
+ displaceRenderSVec (hexVec2SVec size 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) }
+ 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
+ FilledHexGlyph _ -> False
+ HollowGlyph _ -> False
+ BlockedBlock _ _ _ -> False
+ BlockedPush _ _ -> False
+ CollisionMarker -> 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) =
+ thickLinesR points 1 $ brightness col
+ where
+ n :: Int
+ 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
+ s = corner (hextant dir' - 1)
+ off = corner (hextant dir')
+ e = corner (hextant dir' - 3)
+ 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 (TileGlyph (PivotTile dir) col) = do
+ rimmedCircleR zero (7/8) col $ bright col
+ when (dir /= zero)
+ $ aaLineR from to $ bright col
+ return ()
+ where
+ from = (7/8) **^ edge (neg dir)
+ to = (7/8) **^ edge dir
+
+renderGlyph (TileGlyph (ArmTile dir _) col) =
+ thickLineR from to 1 col
+ where
+ dir' = if dir == zero then hu else dir
+ from = edge $ neg dir'
+ to = innerCorner dir'
+
+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 (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 (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 $ (0x90 * (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 ()
diff --git a/SDLRender.hs b/SDLRender.hs
index d4c6faa..29cb84b 100644
--- a/SDLRender.hs
+++ b/SDLRender.hs
@@ -8,6 +8,7 @@
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see http://www.gnu.org/licenses/.
+-- |SDLRender: generic wrapper around sdl-gfx for drawing on hex grids
module SDLRender where
import Graphics.UI.SDL
@@ -16,459 +17,20 @@ 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
-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 = do
- sequence [ arc surf (fi $ x - (2*size`div`3)) (fi y) r (-20) 20
- (if use then bright green else dim red)
- | r <- map fi $ map (*(size`div`3)) [1,2,3] ]
- when (not use) $ void $ aaLine surf
- `uncurry` (innerCorner centre size hw)
- `uncurry` (innerCorner centre size $ neg hw) $ dim red
-
-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
-
+-- |SVec: screen vectors, in pixels
data SVec = SVec { cx, cy :: Int }
deriving (Eq, Ord, Show)
instance Monoid SVec where
@@ -478,10 +40,31 @@ instance Grp SVec where
neg (SVec x y) = SVec (-x) (-y)
type CCoord = PHS SVec
+-- |FVec: floating point screen vectors, multiplied by 'size' to get SVecs.
+data FVec = FVec { rcx, rcy :: Float }
+ deriving (Eq, Ord, Show)
+instance Monoid FVec where
+ mempty = FVec 0 0
+ mappend (FVec x y) (FVec x' y') = FVec (x+x') (y+y')
+instance Grp FVec where
+ neg (FVec x y) = FVec (-x) (-y)
+
+-- The following leads to overlapping instances (not sure why):
+--instance MultAction Float FVec where
+-- r *^ FVec x y = FVec (r*x) (r*y)
+-- So instead, we define a new operator:
+(**^) :: Float -> FVec -> FVec
+r **^ FVec x y = FVec (r*x) (r*y)
+
+
hexVec2SVec :: Int -> HexVec -> SVec
hexVec2SVec size (HexVec x y z) =
SVec ((x-z) * size) (-y * 3 * ysize size)
+hexVec2FVec :: HexVec -> FVec
+hexVec2FVec (HexVec x y z) =
+ FVec (fi $ x-z) (-(fi y) * 3 * ylen)
+
sVec2dHV :: Int -> SVec -> (Double,Double,Double)
sVec2dHV size (SVec sx sy) =
let sx',sy',size' :: Double
@@ -503,6 +86,7 @@ sVec2HexVec size sv =
Map.adjust (\x -> x - (sum $ Map.elems rounded)) maxdiff rounded
in HexVec x y z
+
data RenderContext = RenderContext
{ renderSurf :: Surface
, renderBGSurf :: Maybe Surface
@@ -511,76 +95,218 @@ data RenderContext = RenderContext
, renderSize :: Int
, renderFont :: Maybe TTF.Font
}
-type RenderM = ReaderT RenderContext (StateT CachedGlyphs IO)
+type RenderT = ReaderT RenderContext
+
+runRenderT = runReaderT
-runRenderM :: RenderM a -> CachedGlyphs -> RenderContext -> IO (a,CachedGlyphs)
-runRenderM m cgs rc = runStateT (runReaderT m rc) cgs
+displaceRender :: Monad m => FVec -> RenderT m a -> RenderT m a
+displaceRender v m = do
+ size <- asks renderSize
+ let FVec x y = fi size **^ v
+ let sv = SVec (round x) (round y)
+ displaceRenderSVec sv m
-displaceRender :: SVec -> RenderM a -> RenderM a
-displaceRender disp = local displace
- where displace rc = rc { renderSCentre = renderSCentre rc +^ disp }
+displaceRenderSVec :: Monad m => SVec -> RenderT m a -> RenderT m a
+displaceRenderSVec sv =
+ local $ \rc -> rc { renderSCentre = renderSCentre rc +^ sv }
-recentreAt :: HexVec -> RenderM a -> RenderM a
+recentreAt :: Monad m => HexVec -> RenderT m a -> RenderT m a
recentreAt v m = do
size <- asks renderSize
- displaceRender (hexVec2SVec size v) m
+ displaceRenderSVec (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) }
+rescaleRender :: Monad m => RealFrac n => n -> RenderT m a -> RenderT m a
+rescaleRender r = local $ \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 }
+withFont :: Monad m => Maybe TTF.Font -> RenderT m a -> RenderT m a
+withFont font = local $ \rc -> rc { renderFont = font }
-erase :: RenderM ()
-erase = fillRectBG Nothing
+renderPos :: Monad m => Integral i => FVec -> RenderT m (i,i)
+renderPos v = do
+ size <- asks renderSize
+ let FVec dx dy = fi size **^ v
+ SVec x y <- asks renderSCentre
+ return $ (fi x + round dx, fi y + round dy)
+renderLen :: Monad m => Integral i => Float -> RenderT m i
+renderLen l = do
+ size <- asks renderSize
+ return $ round $ l * fi size
-fillRectBG :: Maybe Rect -> RenderM ()
-fillRectBG mrect = do
+
+-- wrappers around sdl-gfx functions
+pixelR v col = do
+ (x,y) <- renderPos v
surf <- asks renderSurf
- mbgsurf <- asks renderBGSurf
- void $ liftIO $ maybe
- (fillRect surf mrect black)
- (\bgsurf -> blitSurface bgsurf mrect surf mrect)
- mbgsurf
+ void.liftIO $ pixel surf x y col
+
+aaLineR v v' col = do
+ (x,y) <- renderPos v
+ (x',y') <- renderPos v'
+ surf <- asks renderSurf
+ void.liftIO $ aaLine surf x y x' y' col
+
+filledPolygonR verts fillCol = do
+ ps <- mapM renderPos verts
+ surf <- asks renderSurf
+ void.liftIO $ filledPolygon surf ps fillCol
+
+arcR v rad a1 a2 col = do
+ (x,y) <- renderPos v
+ r <- renderLen rad
+ surf <- asks renderSurf
+ void.liftIO $ arc surf x y r a1 a2 col
+
+filledCircleR v rad col = do
+ (x,y) <- renderPos v
+ r <- renderLen rad
+ surf <- asks renderSurf
+ void.liftIO $ filledCircle surf x y r col
+
+-- aaPolygon seems to be a bit buggy in sdl-gfx-0.6.0
+aaPolygonR verts col =
+ aaLinesR (verts ++ take 1 verts) col
+
+-- aaCircle too
+aaCircleR v rad col = do
+ (x,y) <- renderPos v
+ r <- renderLen rad
+ surf <- asks renderSurf
+ if (r <= 1) then void.liftIO $ pixel surf x y col
+ else void.liftIO $ aaCircle surf x y r col
+
+
+aaLinesR verts col =
+ sequence_ [ aaLineR v v' col |
+ (v,v') <- zip (take (length verts - 1) verts) (drop 1 verts) ]
+
+rimmedPolygonR verts fillCol rimCol = do
+ filledPolygonR verts fillCol
+ aaPolygonR verts $ opaquify rimCol
+ return ()
+
+rimmedCircleR v rad fillCol rimCol = void $ do
+ filledCircleR v rad fillCol
+ aaCircleR v rad $ opaquify rimCol
+
+thickLineR :: (Functor m, MonadIO m) => FVec -> FVec -> Float -> Pixel -> RenderT m ()
+thickLineR from to thickness col =
+ let FVec dx dy = to -^ from
+ baseThickness = (1/16)
+ s = baseThickness * thickness / (sqrt $ dx^2 + dy^2)
+ perp = (s/2) **^ FVec dy (-dx)
+ in rimmedPolygonR
+ [ from +^ perp, to +^ perp
+ , to +^ neg perp, from +^ neg perp]
+ (dim col) (bright col)
+
+thickLinesR verts thickness col =
+ sequence_ [ thickLineR v v' thickness col |
+ (v,v') <- zip (take (length verts - 1) verts) (drop 1 verts) ]
+
+thickPolygonR verts thickness col =
+ thickLinesR (verts ++ take 1 verts) thickness col
-drawBasicBG :: Int -> RenderM ()
-drawBasicBG maxR = sequence_ [ drawAtRel (HollowGlyph $ colAt v) v | v <- hexDisc maxR ]
+
+ylen = 1 / sqrt 3
+ysize :: Int -> Int
+ysize = (map (\size -> round $ fi size * ylen) [0..] !!)
+
+corner :: Int -> FVec
+corner hextant = FVec x y
+ where
+ [x,y] = f hextant
+ f 0 = [1, -ylen]
+ f 1 = [0, -2*ylen]
+ f 2 = [-1, -ylen]
+ f n | n < 6 = let [x,y] = f (5-n) in [x,-y]
+ | n < 0 = f (6-n)
+ | otherwise = f (n`mod`6)
+
+innerCorner :: HexDir -> FVec
+innerCorner dir = FVec x y
+ where
+ [x,y] = f dir
+ f dir
+ | dir == hu = [2/3, 0]
+ | dir == hv = [-1/3, -ylen]
+ | dir == hw = [-1/3, ylen]
+ | not (isHexDir dir) = error "innerCorner: not a hexdir"
+ | otherwise = map (\z -> -z) $ f $ neg dir
+
+edge :: HexDir -> FVec
+edge dir = FVec x y
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
+ [x,y] = f dir
+ f dir
+ | dir == hu = [1, 0]
+ | dir == hv = [-1/2, -3*ylen/2]
+ | dir == hw = [-1/2, 3*ylen/2]
+ | not (isHexDir dir) = error "edge: not a hexdir"
+ | otherwise = map (\z -> -z) $ f $ neg dir
+
+
+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 :: Ord i => Map i Int -> i -> Pixel
+colourOf colouring idx =
+ case Map.lookup idx colouring of
+ Nothing -> white
+ Just n -> colourWheel n
+
+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)
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,renderStrColAtLeft :: (Functor m, MonadIO m) => Pixel -> String -> HexVec -> RenderT m ()
renderStrColAt = renderStrColAt' True
-renderStrColAt' :: Bool -> Pixel -> String -> HexVec -> RenderM ()
+renderStrColAtLeft = renderStrColAt' False
+renderStrColAt' :: (Functor m, MonadIO m) => Bool -> Pixel -> String -> HexVec -> RenderT m ()
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
+ (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
@@ -588,56 +314,33 @@ renderStrColAt' centred c str v = void $ runMaybeT $ do
else SVec 0 0)
void $ liftIO $ blitSurface fsurf Nothing surf (Just $ Rect x y 0 0)
+renderStrColAbove,renderStrColBelow :: (Functor m, MonadIO m) => Pixel -> String -> HexVec -> RenderT m ()
renderStrColAbove = renderStrColVShifted True
renderStrColBelow = renderStrColVShifted False
-renderStrColVShifted :: Bool -> Pixel -> String -> HexVec -> RenderM ()
-renderStrColVShifted up c str v = do
- size <- asks renderSize
- displaceRender (SVec size 0) $ renderStrColAt c str $ v +^ (if up then hv else hw)
+renderStrColVShifted :: (Functor m, MonadIO m) => Bool -> Pixel -> String -> HexVec -> RenderT m ()
+renderStrColVShifted up c str v =
+ displaceRender (FVec 1 0) $ renderStrColAt c str $ v +^ (if up then hv else hw)
+
+erase :: (Functor m, MonadIO m) => RenderT m ()
+erase = fillRectBG Nothing
+
+fillRectBG :: (Functor m, MonadIO m) => Maybe Rect -> RenderT m ()
+fillRectBG mrect = do
+ surf <- asks renderSurf
+ mbgsurf <- asks renderBGSurf
+ void $ liftIO $ maybe
+ (fillRect surf mrect black)
+ (\bgsurf -> blitSurface bgsurf mrect surf mrect)
+ mbgsurf
blankRow v = do
- (surf, scrCentre, size) <- asks $
- liftM3 (,,) renderSurf renderSCentre renderSize
+ (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 :: (Functor m, MonadIO m) => Surface -> HexVec -> RenderT m ()
blitAt surface v = do
(surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize
let SVec x y = scrCentre +^ (hexVec2SVec size v)
diff --git a/SDLUI.hs b/SDLUI.hs
index bf137c5..416d2bb 100644
--- a/SDLUI.hs
+++ b/SDLUI.hs
@@ -49,6 +49,7 @@ import KeyBindings
import Mundanities
import Metagame
import SDLRender
+import SDLGlyph
import InputMode
import Maxlocksize
import Util
@@ -163,8 +164,8 @@ getButtons mode = do
++ [ singleButton tr CmdOpen 1 [("open", hu+^neg hw)] ]
IMReplay -> [ markGroup ]
IMMeta ->
- [ singleButton serverPos CmdSetServer 0 [("server",3*^hw)]
- , singleButton (serverPos+^neg hu) CmdToggleCacheOnly 0 [("cache",hv+^6*^neg hu),("only",hw+^5*^neg hu)]
+ [ singleButton serverPos CmdSetServer 0 [("server",7*^neg hu)]
+ , singleButton (serverPos+^hw) CmdToggleCacheOnly 0 [("offline",hv+^7*^neg hu),("mode",hw+^5*^neg hu)]
, singleButton (codenamePos +^ 2*^neg hu) (CmdSelCodename Nothing) 2 [("code",hv+^5*^neg hu),("name",hw+^5*^neg hu)]
, singleButton (serverPos +^ 2*^neg hv +^ 2*^hw) CmdTutorials 3 [("play",hu+^neg hw),("tut",hu+^neg hv)]
]
@@ -705,7 +706,8 @@ drawButtons mode = do
smallFont <- gets dispFontSmall
renderToMain $ sequence_ $ concat [ [ do
drawAtRel (ButtonGlyph col) v
- renderStrColAt buttonTextCol bdg v
+ (if length bdg > 2 then withFont smallFont else id) $
+ renderStrColAt buttonTextCol bdg v
when showBT $
withFont smallFont $ recentreAt v $ rescaleRender (1/4) $
sequence_ [ renderStrColAtLeft white s dv | (s,dv) <- helps ]
diff --git a/SDLUIMInstance.hs b/SDLUIMInstance.hs
index 1a64165..4d08874 100644
--- a/SDLUIMInstance.hs
+++ b/SDLUIMInstance.hs
@@ -48,6 +48,7 @@ import ServerAddr
import Util
import InputMode
import SDLRender
+import SDLGlyph
import SDLUI
instance UIMonad (StateT UIState IO) where
@@ -123,7 +124,7 @@ instance UIMonad (StateT UIState IO) where
lift $ do
smallFont <- gets dispFontSmall
renderToMain $ withFont smallFont $ renderStrColAtLeft purple
- (saddrStr saddr ++ if cOnly then " (cache only)" else "")
+ (saddrStr saddr ++ if cOnly then " (offline mode)" else "")
$ serverPos +^ hu
when (length names > 1) $ lift $ registerButton
@@ -164,7 +165,8 @@ instance UIMonad (StateT UIState IO) where
(i,mlockinfo) <- assocs $ userLocks uinfo ]
when (isJust $ msum $ elems $ userLocks uinfo) $ lift $ do
registerButton interactButtonsPos (CmdSolve Nothing) 2 [("solve",hu+^neg hw),("lock",hu+^neg hv)]
- registerButton (interactButtonsPos+^hw) (CmdViewSolution Nothing) 1 [("view",hu+^neg hw),("soln",hu+^neg hv)]
+ when (isJust ourName) $
+ registerButton (interactButtonsPos+^hw) (CmdViewSolution Nothing) 1 [("view",hu+^neg hw),("soln",hu+^neg hv)]
when home $ do
lift.renderToMain $ renderStrColAt messageCol
@@ -254,13 +256,20 @@ instance UIMonad (StateT UIState IO) where
reportAlerts = playAlertSounds
- getChRaw = do
- events <- liftIO getEvents
- if not.null $ [ True | MouseButtonDown _ _ ButtonRight <- events ]
- then return Nothing
- else maybe getChRaw (return.Just) $ listToMaybe $ [ ch
- | KeyDown (Keysym _ _ ch) <- events
- , ch /= '\0' ]
+ getChRaw = resetMouseButtons >> getChRaw'
+ where
+ resetMouseButtons = modify $ \s -> s
+ { leftButtonDown = Nothing
+ , middleButtonDown = Nothing
+ , rightButtonDown = Nothing
+ }
+ getChRaw' = do
+ events <- liftIO getEvents
+ if not.null $ [ True | MouseButtonDown _ _ ButtonRight <- events ]
+ then return Nothing
+ else maybe getChRaw' (return.Just) $ listToMaybe $ [ ch
+ | KeyDown (Keysym _ _ ch) <- events
+ , ch /= '\0' ]
setUIBinding mode cmd ch =
modify $ \s -> s { uiKeyBindings =
@@ -732,8 +741,8 @@ drawNameWithChar name charcol char pos = do
drawNameWithCharAndCol :: String -> Pixel -> Char -> Pixel -> HexVec -> MainStateT UIM ()
drawNameWithCharAndCol name charcol char col pos = do
size <- fi.snd <$> lift getGeom
- let up = SVec 0 $ - (ysize size - size`div`2)
- let down = SVec 0 $ ysize size
+ let up = FVec 0 $ 1/2 - ylen
+ let down = FVec 0 $ ylen
smallFont <- lift $ gets dispFontSmall
lift.renderToMain $ do
drawAtRel (playerGlyph col) pos
@@ -786,7 +795,7 @@ drawLockInfo al@(ActiveLock name idx) (Just lockinfo) = do
size <- snd <$> lift getGeom
lift $ do
- renderToMain $ displaceRender (SVec size 0) $ renderStrColAt (brightish white) "UNLOCKED BY" $ accessedByPos +^ hv
+ renderToMain $ displaceRender (FVec 1 0) $ renderStrColAt (brightish white) "UNLOCKED BY" $ accessedByPos +^ hv
registerSelectable (accessedByPos +^ hv) 0 SelPrivyHeader
registerSelectable (accessedByPos +^ hv +^ hu) 0 SelPrivyHeader
if public lockinfo
@@ -829,7 +838,7 @@ drawLockInfo al@(ActiveLock name idx) (Just lockinfo) = do
renderToMain (drawAtRel (HollowGlyph $ dim green) pos)))
lift $ do
- renderToMain $ displaceRender (SVec size 0) $ renderStrColAt (brightish white) "SECURING" $ notesPos +^ hv
+ renderToMain $ displaceRender (FVec 1 0) $ renderStrColAt (brightish white) "SECURING" $ notesPos +^ hv
registerSelectable (notesPos +^ hv) 0 SelNotesHeader
registerSelectable (notesPos +^ hv +^ hu) 0 SelNotesHeader
if null $ notesSecured lockinfo
diff --git a/Server.hs b/Server.hs
index 2e52505..49ea950 100644
--- a/Server.hs
+++ b/Server.hs
@@ -8,6 +8,8 @@
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see http://www.gnu.org/licenses/.
+{-# LANGUAGE ScopedTypeVariables #-}
+
module Main where
import Network.Fancy
@@ -29,7 +31,7 @@ import Data.Time.Clock
import System.IO
import System.FilePath
import System.Directory (renameFile)
-import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as CS
import qualified Data.Binary as B
import qualified Data.Text as TS
@@ -49,6 +51,10 @@ import Text.XML.Light.Output (showTopElement)
import Data.Time.Format
import Data.Time.LocalTime
+import Crypto.Types.PubKey.RSA (PublicKey, PrivateKey)
+import Codec.Crypto.RSA (decrypt, generateKeyPair, RSAError)
+import Crypto.Random (newGenIO, SystemRandom)
+
import qualified Text.Email.Validate
import qualified Network.Mail.SMTP as SMTP
@@ -108,7 +114,7 @@ main = do
dbpath = fromMaybe "intricacydb" $ listToMaybe [ p | DBDir p <- opts ]
mfeedPath = listToMaybe [ p | FeedPath p <- opts ]
locksize = min maxlocksize $ fromMaybe 8 $ listToMaybe [ s | ServerLockSize s <- opts ]
- withDB dbpath $ setDefaultServerInfo locksize
+ withDB dbpath $ setDefaultServerInfo locksize >> setKeyPair
writeFile (lockFilePath dbpath) ""
logh <- case listToMaybe [ f | LogFile f <- opts ] of
Nothing -> return stdout
@@ -120,6 +126,17 @@ setDefaultServerInfo locksize = do
alreadySet <- recordExists RecServerInfo
unless alreadySet $ putRecord RecServerInfo (RCServerInfo $ defaultServerInfo locksize)
+rsaKeyLength = 2048
+
+setKeyPair :: DBM ()
+setKeyPair = do
+ alreadySet <- recordExists RecPublicKey
+ unless alreadySet $ do
+ g <- liftIO newGenIO :: DBM SystemRandom
+ let (publicKey, secretKey, _) = generateKeyPair g rsaKeyLength
+ putRecord RecPublicKey $ RCPublicKey publicKey
+ putRecord RecSecretKey $ RCSecretKey secretKey
+
-- | We lock the whole database during each request, using haskell's native
-- file locking, meaning that we have at any time one writer *xor* any number
-- of readers.
@@ -142,7 +159,7 @@ handler dbpath delay logh mfeedPath hdl addr = handle ((\e -> return ()) :: Some
handler' hdl addr
where handler' hdl addr = do
response <- handle (\e -> return $ ServerError $ show (e::SomeException)) $ do
- request <- B.decode <$> L.hGetContents hdl
+ request <- B.decode <$> BL.hGetContents hdl
let hostname = case addr of
IP n _ -> n
IPv4 n _ -> n
@@ -156,7 +173,7 @@ handler dbpath delay logh mfeedPath hdl addr = handle ((\e -> return ()) :: Some
now' <- liftIO getCurrentTime
logit logh $ show now' ++ ": " ++ hashedHostname ++ " <<< " ++ showResponse response
return response
- L.hPut hdl $ B.encode response
+ BL.hPut hdl $ B.encode response
showRequest :: ClientRequest -> String
showRequest (ClientRequest ver mauth act) = show ver ++ " "
@@ -179,6 +196,7 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
let lockMode = case action of
Authenticate -> ReadMode
GetServerInfo -> ReadMode
+ GetPublicKey -> ReadMode
GetLock _ -> ReadMode
GetUserInfo _ _ -> ReadMode
GetRetired _ -> ReadMode
@@ -235,6 +253,7 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
ResetPassword passwd -> resetPassword auth passwd >> return ServerAck
SetEmail address -> setEmail auth address >> return ServerAck
GetServerInfo -> ServedServerInfo <$> getServerInfo
+ GetPublicKey -> ServedPublicKey <$> getPublicKey
GetLock ls -> ServedLock <$> getLock ls
GetRetired name -> ServedRetired <$> getRetired name
GetUserInfo name mversion -> (do
@@ -342,6 +361,9 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
getServerInfo = do
RCServerInfo sinfo <- getRecordErrored $ RecServerInfo
return sinfo
+ getPublicKey = do
+ RCPublicKey publicKey <- getRecordErrored $ RecPublicKey
+ return publicKey
getRetired name = do
RCLockSpecs lss <- fromMaybe (RCLockSpecs []) <$> (erroredDB $ getRecord $ RecRetiredLocks name)
return lss
@@ -361,25 +383,35 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
let Just (Auth name _) = auth
getUserInfo name
+ decryptPassword :: String -> ExceptT String IO String
+ decryptPassword pw = do
+ RCSecretKey secretKey <- getRecordErrored RecSecretKey
+ liftIO $ evaluate (CS.unpack . BL.toStrict .
+ decrypt secretKey . BL.fromStrict . CS.pack $ pw)
+ -- <=intricacy-0.6.2 sends the hashed password unencrypted
+ `catch` \(e :: RSAError) -> return pw
checkAuth :: Maybe Auth -> ExceptT String IO ()
checkAuth Nothing = throwE "Authentication required"
checkAuth (Just (Auth name pw)) = do
exists <- checkCodeName name
unless exists $ throwE "No such user"
- RCPassword pw' <- getRecordErrored (RecPassword name)
- when (pw /= pw') $ throwE "Wrong password"
+ RCPassword correctPw <- getRecordErrored (RecPassword name)
+ pw' <- decryptPassword pw
+ when (pw' /= correctPw) $ throwE "Wrong password"
newUser :: Maybe Auth -> ExceptT String IO ()
newUser Nothing = throwE "Require authentication"
newUser (Just (Auth name pw)) = do
exists <- checkCodeName name
when exists $ throwE "Codename taken"
- erroredDB $ putRecord (RecPassword name) (RCPassword pw)
+ pw' <- decryptPassword pw
+ erroredDB $ putRecord (RecPassword name) (RCPassword pw')
erroredDB $ putRecord (RecUserInfo name) (RCUserInfo $ (1,initUserInfo name))
erroredDB $ putRecord (RecUserInfoLog name) (RCUserInfoDeltas [])
- resetPassword Nothing pw = throwE "Authentication required"
+ resetPassword Nothing _ = throwE "Authentication required"
resetPassword auth@(Just (Auth name _)) newpw = do
checkAuth auth
- erroredDB $ putRecord (RecPassword name) (RCPassword newpw)
+ newpw' <- decryptPassword newpw
+ erroredDB $ putRecord (RecPassword name) (RCPassword newpw')
setEmail Nothing _ = throwE "Authentication required"
setEmail auth@(Just (Auth name _)) addressStr = do
checkAuth auth
@@ -437,11 +469,11 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
addDelta name $ LockDelta idx $ SetPubNote note
publified <- checkSuffPubNotes al
unless publified $ do
- lock <- getCurrALock al
- accessorsOfNotesOnLock <- ((++ map noteAuthor (lockSolutions lock)).concat)
- <$> (sequence
- [ accessedBy <$> getCurrALock behind | NoteInfo _ (Just behind) _ <- lockSolutions lock ] )
- forM_ accessorsOfNotesOnLock $ checkSuffReadNotes al
+ lock <- getCurrALock al
+ accessorsOfNotesOnLock <- ((++ map noteAuthor (lockSolutions lock)).concat)
+ <$> (sequence
+ [ accessedBy <$> getCurrALock behind | NoteInfo _ (Just behind) _ <- lockSolutions lock ] )
+ forM_ accessorsOfNotesOnLock $ checkSuffReadNotes al
checkSuffReadNotes target name = do
info <- getCurrUserInfo name
tlock <- getCurrALock target
@@ -449,8 +481,7 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
when (countRead info tlock == notesNeeded) $
accessLock name target tlock
checkSuffPubNotes al@(ActiveLock name idx) = do
- info <- getCurrUserInfo name
- let Just lock = userLocks info ! idx
+ lock <- getCurrALock al
let countPub = fromIntegral $ length $
filter (isNothing.noteBehind) $ lockSolutions lock
if (countPub == notesNeeded)
diff --git a/Version.hs b/Version.hs
index f961b02..74b8603 100644
--- a/Version.hs
+++ b/Version.hs
@@ -11,4 +11,4 @@
module Version where
version :: String
-version = "0.6.2"
+version = "0.7"
diff --git a/intricacy.cabal b/intricacy.cabal
index 7c00daa..202626b 100644
--- a/intricacy.cabal
+++ b/intricacy.cabal
@@ -1,5 +1,5 @@
name: intricacy
-version: 0.6.2
+version: 0.7
synopsis: A game of competitive puzzle-design
homepage: http://mbays.freeshell.org/intricacy
license: GPL-3
@@ -59,6 +59,7 @@ executable intricacy
, binary >=0.5, network-fancy >= 0.1.5
, cryptohash >= 0.8
, safe >= 0.2
+ , RSA >= 2.0, crypto-pubkey-types >= 0.2, crypto-api >= 0.10
if flag(SDL)
build-depends: SDL >=0.6.5, SDL-ttf >=0.6, SDL-gfx >=0.6
if flag(Sound)
@@ -103,8 +104,8 @@ executable intricacy
CursesRender, CursesUI, CursesUIMInstance, CVec, Database, Debug,
EditGameState, Frame, GameState, GameStateTypes, GraphColouring, Hex, Init,
InputMode, Interact, InteractUtil, KeyBindings, Lock, MainState,
- Maxlocksize, Metagame, Mundanities, Physics, Protocol, SDLRender, SDLUI,
- SDLUIMInstance, ServerAddr, Util, Version
+ Maxlocksize, Metagame, Mundanities, Physics, Protocol, SDLGlyph,
+ SDLRender, SDLUI, SDLUIMInstance, ServerAddr, Util, Version
executable intricacy-server
if flag(Server)
@@ -116,6 +117,7 @@ executable intricacy-server
, array >=0.3, containers >=0.4, vector >=0.9
, binary >=0.5, network-fancy >= 0.1.5
, cryptohash >= 0.8
+ , RSA >= 2.0, crypto-pubkey-types >= 0.2, crypto-api >= 0.10
, random >= 1.0, pipes >= 4
, feed >= 0.3.1, xml >= 1.2.6
, email-validate >= 1.0.0, text, smtp-mail >= 0.1.4.1