intricacy 0.6.2 → 0.7
raw patch · 21 files changed
+1052/−671 lines, 21 filesdep +RSAdep +crypto-apidep +crypto-pubkey-types
Dependencies added: RSA, crypto-api, crypto-pubkey-types
Files
- Cache.hs +1/−1
- Command.hs +1/−1
- CursesUI.hs +131/−1
- CursesUIMInstance.hs +140/−83
- Database.hs +14/−1
- Frame.hs +0/−1
- Interact.hs +44/−14
- InteractUtil.hs +5/−3
- KeyBindings.hs +18/−7
- MainState.hs +8/−4
- Metagame.hs +1/−1
- Mundanities.hs +4/−2
- NEWS +6/−0
- Protocol.hs +10/−1
- SDLGlyph.hs +371/−0
- SDLRender.hs +218/−515
- SDLUI.hs +5/−3
- SDLUIMInstance.hs +22/−13
- Server.hs +47/−16
- Version.hs +1/−1
- intricacy.cabal +5/−3
Cache.hs view
@@ -32,7 +32,7 @@ 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)
Command.hs view
@@ -76,7 +76,7 @@ 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"
CursesUI.hs view
@@ -21,6 +21,7 @@ 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 @@ 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@@ -68,6 +69,135 @@ return $ (("["++).(++"]")) $ intercalate "," $ 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
CursesUIMInstance.hs view
@@ -23,6 +23,7 @@ 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 @@ 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,28 +168,82 @@ 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 Curses.KeyChar ch -> Just ch@@ -205,6 +258,14 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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+ showHelp = showHelpPaged 0 - getChRaw = (charify<$>) $ liftIO $ CursesH.getKey (return ())+ 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 @@ 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
Database.hs view
@@ -23,6 +23,7 @@ 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 @@ | RecRetiredLocks Codename | RecServerInfo | RecServerEmail+ | RecPublicKey+ | RecSecretKey deriving (Eq, Ord, Show) data RecordContents = RCPassword Password@@ -57,13 +60,16 @@ | 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 (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 (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 (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' 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
Frame.hs view
@@ -30,7 +30,6 @@ boltWidth :: Frame -> Int boltWidth (BasicFrame size) = size`div`4+1 - baseState :: Frame -> GameState baseState f = GameState
Interact.hs view
@@ -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 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,7 +31,13 @@ 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 import Physics@@ -214,24 +223,23 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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
InteractUtil.hs view
@@ -60,10 +60,12 @@ 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
KeyBindings.hs view
@@ -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 @@ 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 @@ 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 '\t' = "tab" showKeyFriendly '\b' = "bksp" showKeyFriendly ch = showKey ch++showKeyFriendlyShort '\r' = "ret"+showKeyFriendlyShort '\t' = "tab"+showKeyFriendlyShort '\b' = "bksp"+showKeyFriendlyShort ch = showKey ch
MainState.hs view
@@ -289,6 +289,10 @@ 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 @@ 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 @@ 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."
Metagame.hs view
@@ -126,7 +126,7 @@ 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
Mundanities.hs view
@@ -14,6 +14,7 @@ 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 @@ 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
NEWS view
@@ -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.
Protocol.hs view
@@ -13,6 +13,8 @@ import Data.Binary import Control.Monad +import Crypto.Types.PubKey.RSA (PublicKey)+ import BinaryInstances import Metagame import Lock@@ -31,6 +33,7 @@ | ResetPassword Password | SetEmail String | GetServerInfo+ | GetPublicKey | GetLock LockSpec | GetRetired Codename | GetUserInfo Codename (Maybe Int)@@ -48,6 +51,7 @@ needsAuth :: Action -> Bool needsAuth GetServerInfo = False+needsAuth GetPublicKey = False needsAuth (GetLock _) = False needsAuth (GetUserInfo _ _) = False needsAuth (GetRetired _) = False@@ -59,6 +63,7 @@ | ServerMessage String | ServerError String | ServedServerInfo ServerInfo+ | ServedPublicKey PublicKey | ServedLock Lock | ServedRetired [LockSpec] | ServedUserInfo VersionedUInfo@@ -69,7 +74,7 @@ | 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 @@ 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 @@ 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 @@ 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 @@ 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
+ SDLGlyph.hs view
@@ -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 ()
SDLRender.hs view
@@ -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,435 +17,234 @@ 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+-- |SVec: screen vectors, in pixels+data SVec = SVec { cx, cy :: Int }+ deriving (Eq, Ord, Show)+instance Monoid SVec where+ mempty = SVec 0 0+ mappend (SVec x y) (SVec x' y') = SVec (x+x') (y+y')+instance Grp SVec where+ neg (SVec x y) = SVec (-x) (-y)+type CCoord = PHS SVec -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) ]+-- |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) -rimmedPolygon surf verts fillCol rimCol = do- filledPolygon surf verts fillCol- aaPolygon' surf verts $ opaquify rimCol- return ()+-- 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)+ -circleAt surf centre@(SVec x y) rad col =- aaCircle' surf (fi x) (fi y) (fi rad) col+hexVec2SVec :: Int -> HexVec -> SVec+hexVec2SVec size (HexVec x y z) =+ SVec ((x-z) * size) (-y * 3 * ysize size) -filledCircleAt surf centre@(SVec x y) rad col =- filledCircle surf (fi x) (fi y) (fi rad) col+hexVec2FVec :: HexVec -> FVec+hexVec2FVec (HexVec x y z) =+ FVec (fi $ x-z) (-(fi y) * 3 * ylen) -rimmedCircle surf centre@(SVec x y) rad fillCol rimCol = void $ do- filledCircleAt surf centre rad fillCol- circleAt surf centre rad $ opaquify rimCol+sVec2dHV :: Int -> SVec -> (Double,Double,Double)+sVec2dHV size (SVec sx sy) =+ let sx',sy',size' :: Double+ [sx',sy',size',ysize'] = map fi [sx,sy,size,ysize size]+ y' = -sy' / ysize' / 3+ x' = ((sx' / size') - y') / 2+ z' = -((sx' / size') + y') / 2+ in (x',y',z') -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)+sVec2HexVec :: Int -> SVec -> HexVec+sVec2HexVec size sv =+ let (x',y',z') = sVec2dHV size sv+ unrounded = Map.fromList [(1,x'),(2,y'),(3,z')]+ rounded = Map.map round unrounded+ maxdiff = fst $ maximumBy (compare `on` snd) $+ [ (i, abs $ c'-c) | i <- [1..3],+ let c' = unrounded Map.! i, let c = fi $ rounded Map.! i]+ [x,y,z] = map snd $ Map.toList $+ Map.adjust (\x -> x - (sum $ Map.elems rounded)) maxdiff rounded+ in HexVec x y z -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+data RenderContext = RenderContext+ { renderSurf :: Surface+ , renderBGSurf :: Maybe Surface+ , renderHCentre :: HexPos+ , renderSCentre :: SVec+ , renderSize :: Int+ , renderFont :: Maybe TTF.Font+ }+type RenderT = ReaderT RenderContext -ysize :: Int -> Int-ysize = (map (\size -> round $ fi size / sqrt 3) [0..] !!)+runRenderT = runReaderT -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)+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 -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+displaceRenderSVec :: Monad m => SVec -> RenderT m a -> RenderT m a+displaceRenderSVec sv =+ local $ \rc -> rc { renderSCentre = renderSCentre rc +^ sv } -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+recentreAt :: Monad m => HexVec -> RenderT m a -> RenderT m a+recentreAt v m = do+ size <- asks renderSize+ displaceRenderSVec (hexVec2SVec size v) m -data ShowBlocks = ShowBlocksBlocking | ShowBlocksAll | ShowBlocksNone- deriving (Eq, Ord, Show, Read)+rescaleRender :: Monad m => RealFrac n => n -> RenderT m a -> RenderT m a+rescaleRender r = local $ \rc -> rc { renderSize = round $ r * (fi $ renderSize rc) } -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)+withFont :: Monad m => Maybe TTF.Font -> RenderT m a -> RenderT m a+withFont font = local $ \rc -> rc { renderFont = font } -type SizedGlyph = (Glyph,Int)-data CachedGlyphs = CachedGlyphs (Map SizedGlyph Surface) [SizedGlyph]- deriving (Eq, Ord, Show)-emptyCachedGlyphs = CachedGlyphs Map.empty []-maxCachedGlyphs = 100+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 -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- ]+-- wrappers around sdl-gfx functions+pixelR v col = do+ (x,y) <- renderPos v+ surf <- asks renderSurf+ void.liftIO $ pixel surf x y col -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) ]+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 -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+filledPolygonR verts fillCol = do+ ps <- mapM renderPos verts+ surf <- asks renderSurf+ void.liftIO $ filledPolygon surf ps fillCol -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'+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 -renderGlyph (TileGlyph HookTile col) centre size surf =- rimmedCircle surf centre rad col $ bright col- where- rad = (7*size)`div`8+filledCircleR v rad col = do+ (x,y) <- renderPos v+ r <- renderLen rad+ surf <- asks renderSurf+ void.liftIO $ filledCircle surf x y r col -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 ]+-- aaPolygon seems to be a bit buggy in sdl-gfx-0.6.0+aaPolygonR verts col =+ aaLinesR (verts ++ take 1 verts) col -renderGlyph (TileGlyph BallTile col) centre size surf =- rimmedCircle surf centre rad (faint col) (obscure col)- where rad = (7*size)`div`8+-- 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 -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'+aaLinesR verts col =+ sequence_ [ aaLineR v v' col |+ (v,v') <- zip (take (length verts - 1) verts) (drop 1 verts) ] -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+rimmedPolygonR verts fillCol rimCol = do+ filledPolygonR verts fillCol+ aaPolygonR verts $ opaquify rimCol+ return () -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]]+rimmedCircleR v rad fillCol rimCol = void $ do+ filledCircleR v rad fillCol+ aaCircleR v rad $ opaquify rimCol - --from' = corner centre size $ hextant dir- --to' = corner centre size $ (hextant dir) - 1+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) -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+thickLinesR verts thickness col =+ sequence_ [ thickLineR v v' thickness col |+ (v,v') <- zip (take (length verts - 1) verts) (drop 1 verts) ] -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 ]+thickPolygonR verts thickness col =+ thickLinesR (verts ++ take 1 verts) thickness col -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] ]+ylen = 1 / sqrt 3+ysize :: Int -> Int+ysize = (map (\size -> round $ fi size * ylen) [0..] !!) -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+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) -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+innerCorner :: HexDir -> FVec+innerCorner dir = FVec x y where- miniSize = size `div` 2- miniCentre h = SVec `uncurry` corner centre miniSize h- col = dim white+ [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 -renderGlyph (FullscreenButton fs) centre size surf = do- thickPolygon surf corners 1 $ activeCol (not fs)- thickPolygon surf corners' 1 $ activeCol fs+edge :: HexDir -> FVec+edge dir = FVec x y 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]+ [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 -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@@ -464,123 +264,49 @@ 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 -data SVec = SVec { cx, cy :: Int }- deriving (Eq, Ord, Show)-instance Monoid SVec where- mempty = SVec 0 0- mappend (SVec x y) (SVec x' y') = SVec (x+x') (y+y')-instance Grp SVec where- neg (SVec x y) = SVec (-x) (-y)-type CCoord = PHS SVec--hexVec2SVec :: Int -> HexVec -> SVec-hexVec2SVec size (HexVec x y z) =- SVec ((x-z) * size) (-y * 3 * ysize size)--sVec2dHV :: Int -> SVec -> (Double,Double,Double)-sVec2dHV size (SVec sx sy) =- let sx',sy',size' :: Double- [sx',sy',size',ysize'] = map fi [sx,sy,size,ysize size]- y' = -sy' / ysize' / 3- x' = ((sx' / size') - y') / 2- z' = -((sx' / size') + y') / 2- in (x',y',z')--sVec2HexVec :: Int -> SVec -> HexVec-sVec2HexVec size sv =- let (x',y',z') = sVec2dHV size sv- unrounded = Map.fromList [(1,x'),(2,y'),(3,z')]- rounded = Map.map round unrounded- maxdiff = fst $ maximumBy (compare `on` snd) $- [ (i, abs $ c'-c) | i <- [1..3],- let c' = unrounded Map.! i, let c = fi $ rounded Map.! i]- [x,y,z] = map snd $ Map.toList $- Map.adjust (\x -> x - (sum $ Map.elems rounded)) maxdiff rounded- in HexVec x y z--data RenderContext = RenderContext- { renderSurf :: Surface- , renderBGSurf :: Maybe Surface- , renderHCentre :: HexPos- , renderSCentre :: SVec- , renderSize :: Int- , renderFont :: Maybe TTF.Font- }-type RenderM = ReaderT RenderContext (StateT CachedGlyphs IO)--runRenderM :: RenderM a -> CachedGlyphs -> RenderContext -> IO (a,CachedGlyphs)-runRenderM m cgs rc = runStateT (runReaderT m rc) cgs--displaceRender :: SVec -> RenderM a -> RenderM a-displaceRender disp = local displace- where displace rc = rc { renderSCentre = renderSCentre rc +^ disp }--recentreAt :: HexVec -> RenderM a -> RenderM a-recentreAt v m = do- size <- asks renderSize- displaceRender (hexVec2SVec size v) m--rescaleRender :: RealFrac n => n -> RenderM a -> RenderM a-rescaleRender r = local resize- where resize rc = rc { renderSize = round $ r * (fi $ renderSize rc) }--withFont :: Maybe TTF.Font -> RenderM a -> RenderM a-withFont font = local refont- where refont rc = rc { renderFont = font }--erase :: RenderM ()-erase = fillRectBG Nothing--fillRectBG :: Maybe Rect -> RenderM ()-fillRectBG mrect = do- surf <- asks renderSurf- mbgsurf <- asks renderBGSurf- void $ liftIO $ maybe- (fillRect surf mrect black)- (\bgsurf -> blitSurface bgsurf mrect surf mrect)- mbgsurf--drawBasicBG :: Int -> RenderM ()-drawBasicBG maxR = sequence_ [ drawAtRel (HollowGlyph $ colAt v) v | v <- hexDisc maxR ]- where- colAt v@(HexVec hx hy hz) = let- [r,g,b] = map (\h -> fi $ ((0xff*)$ 5 + abs h)`div`maxR) [hx,hy,hz]- a = fi $ (0x90 * (maxR - abs (hexLen v)))`div`maxR- in rgbaToPixel (r,g,b,a)--drawAt :: Glyph -> HexPos -> RenderM ()-drawAt gl pos = do- centre <- asks renderHCentre- drawAtRel gl (pos -^ centre)+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 -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+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 @@ 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)
SDLUI.hs view
@@ -49,6 +49,7 @@ import Mundanities import Metagame import SDLRender+import SDLGlyph import InputMode import Maxlocksize import Util@@ -163,8 +164,8 @@ ++ [ 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 @@ 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 ]
SDLUIMInstance.hs view
@@ -48,6 +48,7 @@ import Util import InputMode import SDLRender+import SDLGlyph import SDLUI instance UIMonad (StateT UIState IO) where@@ -123,7 +124,7 @@ 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 @@ (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 @@ 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 @@ 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 @@ 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 @@ 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
Server.hs view
@@ -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 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 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 @@ 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 @@ 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' 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 @@ 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 @@ let lockMode = case action of Authenticate -> ReadMode GetServerInfo -> ReadMode+ GetPublicKey -> ReadMode GetLock _ -> ReadMode GetUserInfo _ _ -> ReadMode GetRetired _ -> ReadMode@@ -235,6 +253,7 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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)
Version.hs view
@@ -11,4 +11,4 @@ module Version where version :: String-version = "0.6.2"+version = "0.7"
intricacy.cabal view
@@ -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 @@ , 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 @@ 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 @@ , 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