diff --git a/AsciiLock.hs b/AsciiLock.hs --- a/AsciiLock.hs +++ b/AsciiLock.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -49,8 +49,8 @@ in boardToAscii colouring . stateBoard $ st lockOfAscii :: AsciiLock -> Maybe Lock -lockOfAscii lines = do - board <- asciiToBoard lines +lockOfAscii ls = do + board <- asciiToBoard ls let size = maximumBound 0 $ hx . (-^origin) <$> Map.keys board frame = BasicFrame size guard $ size > 0 @@ -70,10 +70,10 @@ | y <- [0..(maxy-miny)] ] asciiToBoard :: AsciiLock -> Maybe GameBoard -asciiToBoard lines = +asciiToBoard ls = let asciiBoard :: Map CVec Char asciiBoard = Map.fromList [(CVec y x,ch) - | (line,y) <- zip lines [0..] + | (line,y) <- zip ls [0..] , (ch,x) <- zip line [0..] , ch `notElem` "\t\r\n "] (miny,maxy) = minmax $ cy <$> Map.keys asciiBoard @@ -278,9 +278,9 @@ readAsciiLockFile :: FilePath -> IO (Maybe Lock, Maybe Solution) readAsciiLockFile path = fromLines <$> readStrings path - where fromLines lines = fromMaybe (lockOfAscii lines, Nothing) $ do - guard $ length lines > 2 - let (locklines, [header,solnLine]) = splitAt (length lines - 2) lines + where fromLines ls = fromMaybe (lockOfAscii ls, Nothing) $ do + guard $ length ls > 2 + let (locklines, [header,solnLine]) = splitAt (length ls - 2) ls guard $ isPrefixOf "Solution:" header return (lockOfAscii locklines, solutionOfAscii solnLine `mplus` tryRead solnLine) diff --git a/BUILD b/BUILD --- a/BUILD +++ b/BUILD @@ -3,12 +3,12 @@ Dependencies: EITHER - sdl version 1.2 - sdl-ttf - sdl-gfx - sdl-mixer + sdl2 + sdl2-ttf + sdl2-gfx + sdl2-mixer OR - curses + curses To compile the game on *nix with SDL graphics: Install ghc, cabal, and development packages for the SDL dependencies @@ -19,10 +19,10 @@ Running cabal install as root should install it somewhere global. To compile a curses-only (ascii graphics) build: - cabal install -f -SDL + cabal install -f curses To compile the server: - cabal install -f Server -f -Game + cabal install -f server -f -game The server will be installed as e.g. ~/.cabal/bin/intricacy-server @@ -33,8 +33,7 @@ To compile for windows: This should work as above once you have the dependencies installed - properly. Good luck with that. The mingw32-compiled libraries in winlibs - may or may not help. + properly. Good luck with that. To compile for OSX, or android or whatever other wacky system: No idea, sorry. But please tell me if you manage! diff --git a/BinaryInstances.hs b/BinaryInstances.hs --- a/BinaryInstances.hs +++ b/BinaryInstances.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -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/. +{-# OPTIONS_GHC -fno-warn-orphans #-} + module BinaryInstances where import Control.Monad import Data.Binary @@ -88,6 +90,7 @@ 2 -> liftM2 Hook get get 3 -> Wrench <$> get 4 -> return Ball + _ -> fail "bad tag to Piece" instance Binary Connection where put (Connection (ri,rp) (ei,ep) l) = putPackedInt ri >> put rp >> putPackedInt ei >> put ep >> put l get = do @@ -104,6 +107,7 @@ case tag of 0 -> Free <$> get 1 -> liftM2 Spring get getPackedInt + _ -> fail "bad tag to Link" instance Binary HookForce where put NullHF = put (0::Word8) put (TorqueHF dir) = put (1::Word8) >> putPackedInt dir @@ -114,6 +118,7 @@ 0 -> return NullHF 1 -> TorqueHF <$> getPackedInt 2 -> PushHF <$> get + _ -> fail "bad tag to HookForce" instance Binary Frame where put (BasicFrame s) = putPackedInt s get = BasicFrame <$> getPackedInt @@ -130,3 +135,4 @@ 1 -> HookPush <$> get 2 -> HookTorque <$> getPackedInt 3 -> WrenchPush <$> get + _ -> fail "bad tag to PlayerMove" diff --git a/BoardColouring.hs b/BoardColouring.hs --- a/BoardColouring.hs +++ b/BoardColouring.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -70,8 +70,8 @@ (ns++ns') -- |march around the piece's boundary, returning positions visited and -- neighbouring pieces met (in order) - march idx startPos (pos,basedir) init - | not init && pos == startPos = ([],[]) + march idx startPos (pos,basedir) isInit + | not isInit && pos == startPos = ([],[]) | otherwise = let mn = do (idx',_) <- Map.lookup pos board diff --git a/CVec.hs b/CVec.hs --- a/CVec.hs +++ b/CVec.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 diff --git a/Cache.hs b/Cache.hs --- a/Cache.hs +++ b/Cache.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -25,7 +25,6 @@ import Network.Simple.TCP (connect, recv, send) import System.Directory import System.FilePath -import System.IO import Database import Metagame @@ -42,9 +41,9 @@ newTVarIO (FetchedRecord True (Just "No server set.") Nothing) getRecordCached saddr auth mflag cOnly rec = do fromCache <- withCache saddr $ getRecord rec - let fresh = isJust fromCache && invariantRecord rec - tvar <- newTVarIO (FetchedRecord fresh Nothing fromCache) - unless (cOnly || fresh) $ void $ forkIO $ getRecordFromServer fromCache tvar + let isFresh = isJust fromCache && invariantRecord rec + tvar <- newTVarIO (FetchedRecord isFresh Nothing fromCache) + unless (cOnly || isFresh) $ void $ forkIO $ getRecordFromServer fromCache tvar return tvar where getRecordFromServer fromCache tvar = do @@ -79,9 +78,9 @@ makeRequest :: ServerAddr -> ClientRequest -> IO ServerResponse makeRequest saddr _ | nullSaddr saddr = return $ ServerError "No server set." -makeRequest saddr@(ServerAddr host port) request = +makeRequest saddr@(ServerAddr host prt) request = handle (return . ServerError . (show::SomeException -> String)) $ do - connect host (show port) makeRequest' + connect host (show prt) makeRequest' `catchIO` const (return $ ServerError $ "Cannot connect to "++saddrStr saddr++"!") where makeRequest' (sock,_) = do diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -39,9 +39,9 @@ | CmdSolveInit (Maybe HexVec) | CmdSolve (Maybe LockIndex) | CmdDeclare (Maybe Undeclared) | CmdViewSolution (Maybe NoteInfo) - | CmdSelectLock | CmdNextLock | CmdPrevLock - | CmdEdit | CmdPlaceLock (Maybe LockIndex) - | CmdRegister Bool | CmdAuth + | CmdSelectLock | CmdNextLock | CmdPrevLock | CmdDeleteLock + | CmdEdit | CmdPlaceLock (Maybe LockIndex) | CmdRetireLock + | CmdRegister | CmdAuth | CmdNextPage | CmdPrevPage | CmdToggleColourMode | CmdRedraw | CmdRefresh | CmdSuspend | CmdClear @@ -53,59 +53,60 @@ deriving (Eq, Ord, Show, Read) describeCommand :: Command -> String -describeCommand (CmdDir whs dir) = "move " ++ whsStr whs ++ " " ++ dirStr dir -describeCommand (CmdRotate whs dir) = "rotate " ++ whsStr whs +describeCommand (CmdDir whs dir) = "Move " ++ whsStr whs ++ " " ++ dirStr dir +describeCommand (CmdRotate whs dir) = "Rotate " ++ whsStr whs ++ " " ++ (if dir == 1 then "counter" else "") ++ "clockwise" -describeCommand CmdWait = "nothing" -describeCommand CmdToggle = "toggle tool" -describeCommand CmdOpen = "open lock" +describeCommand CmdWait = "Wait" +describeCommand CmdToggle = "Toggle tool" +describeCommand CmdOpen = "Open lock" describeCommand (CmdTile tile) = tileStr tile -describeCommand CmdMerge = "merge with adjacent piece" -describeCommand CmdMark = "mark state" -describeCommand CmdJumpMark = "jump to marked state" -describeCommand CmdReset = "jump to initial state" -describeCommand CmdSelect = "select piece" -describeCommand CmdUnselect = "unselect piece" -describeCommand CmdDelete = "delete piece" -describeCommand CmdPlay = "play lock" -describeCommand CmdTest = "test lock" -describeCommand CmdUndo = "undo" -describeCommand CmdRedo = "redo" -describeCommand (CmdReplayForward _) = "advance replay" -describeCommand (CmdReplayBack _) = "rewind replay" -describeCommand CmdWriteState = "write lock" -describeCommand CmdInitiation = "revisit initiation" -describeCommand CmdShowRetired = "toggle showing retired locks" -describeCommand CmdSetServer = "set server" -describeCommand CmdToggleCacheOnly = "toggle offline mode" -describeCommand (CmdSelCodename mname) = "select player" +describeCommand CmdMerge = "Merge with adjacent piece" +describeCommand CmdMark = "Mark state" +describeCommand CmdJumpMark = "Jump to marked state" +describeCommand CmdReset = "Jump to initial state" +describeCommand CmdSelect = "Select piece" +describeCommand CmdUnselect = "Unselect piece" +describeCommand CmdDelete = "Delete piece" +describeCommand CmdPlay = "Play lock" +describeCommand CmdTest = "Test lock" +describeCommand CmdUndo = "Undo" +describeCommand CmdRedo = "Redo" +describeCommand (CmdReplayForward _) = "Advance replay" +describeCommand (CmdReplayBack _) = "Rewind replay" +describeCommand CmdWriteState = "Write lock" +describeCommand CmdInitiation = "Revisit initiation" +describeCommand CmdShowRetired = "Toggle showing retired locks" +describeCommand CmdSetServer = "Set server" +describeCommand CmdToggleCacheOnly = "Toggle offline mode" +describeCommand (CmdSelCodename mname) = "Select player" ++ maybe "" (' ':) mname -describeCommand CmdBackCodename = "select last player" -describeCommand CmdHome = "select self" -describeCommand (CmdSolveInit _) = "solve lock" -describeCommand (CmdSolve mli) = "solve lock" +describeCommand CmdBackCodename = "Select last player" +describeCommand CmdHome = "Select self" +describeCommand (CmdSolveInit _) = "Solve lock" +describeCommand (CmdSolve mli) = "Solve lock" ++ maybe "" ((' ':).(:"").lockIndexChar) mli describeCommand (CmdPlayLockSpec mls) = "find lock by number" ++ maybe "" ((' ':).show) mls -describeCommand (CmdDeclare mundecl) = "declare solution" +describeCommand (CmdDeclare mundecl) = "Declare solution" ++ maybe "" (const " [specified solution]") mundecl -describeCommand (CmdViewSolution mnote) = "view lock solution" +describeCommand (CmdViewSolution mnote) = "View lock solution" ++ maybe "" (const " [specified solution]") mnote -describeCommand CmdSelectLock = "choose lock by name" -describeCommand CmdNextLock = "next lock" -describeCommand CmdPrevLock = "previous lock" -describeCommand CmdNextPage = "page forward through lists" -describeCommand CmdPrevPage = "page back through lists" -describeCommand CmdEdit = "edit lock" -describeCommand (CmdPlaceLock mli) = "place lock" +describeCommand CmdSelectLock = "Choose lock by name" +describeCommand CmdNextLock = "Next lock" +describeCommand CmdPrevLock = "Previous lock" +describeCommand CmdDeleteLock = "Delete current lock" +describeCommand CmdNextPage = "Page forward through lists" +describeCommand CmdPrevPage = "Page back through lists" +describeCommand CmdEdit = "Edit lock" +describeCommand (CmdPlaceLock mli) = "Place lock" ++ maybe "" ((' ':).(:"").lockIndexChar) mli -describeCommand (CmdRegister False) = "register codename" -describeCommand (CmdRegister True) = "adjust registration details" -describeCommand CmdAuth = "authenticate" -describeCommand (CmdBind _) = "bind key" -describeCommand CmdToggleColourMode = "toggle lock colour mode" -describeCommand CmdQuit = "quit" -describeCommand CmdHelp = "help" +describeCommand CmdRetireLock = "Retire lock" +describeCommand CmdRegister = "Register codename" +describeCommand CmdAuth = "Authenticate" +describeCommand (CmdBind _) = "Bind key" +describeCommand CmdToggleColourMode = "Toggle lock colour mode" +describeCommand CmdQuit = "Quit" +describeCommand CmdHelp = "Help" describeCommand _ = "" tileStr HookTile = "hook" @@ -117,7 +118,7 @@ tileStr BallTile = "ball" whsStr WHSWrench = "wrench" whsStr WHSHook = "hook" -whsStr WHSSelected = "tool" +whsStr WHSSelected = "selected" dirStr v | v == hu = "right" | v == neg hu = "left" diff --git a/CursesRender.hs b/CursesRender.hs --- a/CursesRender.hs +++ b/CursesRender.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 diff --git a/CursesUI.hs b/CursesUI.hs --- a/CursesUI.hs +++ b/CursesUI.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -12,6 +12,7 @@ import Control.Applicative import Control.Concurrent.STM +import Control.Monad import Control.Monad.State import Control.Monad.Trans.Maybe import Data.Array diff --git a/CursesUIMInstance.hs b/CursesUIMInstance.hs --- a/CursesUIMInstance.hs +++ b/CursesUIMInstance.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -11,19 +11,20 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module CursesUIMInstance () where import Control.Applicative import Control.Concurrent import Control.Concurrent.STM +import Control.Monad import Control.Monad.State import Control.Monad.Trans.Maybe import Data.Array -import Data.Char (chr, ord) +import Data.Char (chr) import Data.Foldable (for_) import Data.Function (on) import Data.List -import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.Monoid @@ -44,7 +45,6 @@ import KeyBindings import MainState import Metagame -import Physics import Protocol import ServerAddr import Util @@ -83,8 +83,8 @@ Just al -> drawActiveLock pos al Nothing -> drawPublicNote pos (noteAuthor note) where - drawPublicNote pos name = - drawNameWithChar pos name magenta 'P' + drawPublicNote pos' name = + drawNameWithChar pos' name magenta 'P' fillBox :: CVec -> CVec -> Int -> Gravity -> [CVec -> MainStateT UIM ()] -> MainStateT UIM Int @@ -108,7 +108,6 @@ dist v = sqlen $ v -^ gravCentre sqlen (CVec y x) = (y*(width+1))^2+x^2 na = length locs - nd = length draws drawChar c cvec = lift . drawStr bold white cvec $ ' ':c:" " draws' = if offset > 0 && length draws > na then drop (max 0 $ na-1 + (na-2)*(offset-1)) draws @@ -120,7 +119,7 @@ zipped = zip locs selDraws unless allDrawn . modify $ \ms -> ms { listOffsetMax = False } mapM_ (uncurry ($)) (zip selDraws locs) - return $ (if grav==GravDown then minimum.(b:) else maximum.(t:)) [ y | (CVec y x,_) <- zipped ] + return $ (if grav==GravDown then minimum.(b:) else maximum.(t:)) [ y | (CVec y _,_) <- zipped ] drawLockInfo al@(ActiveLock name i) lockinfo = do (h,w) <- liftIO Curses.scrSize @@ -134,7 +133,7 @@ lock <- mgetLock $ lockSpec lockinfo let size = frameSize $ fst lock guard $ bottom - top >= 5 + 2*size+1 + 1 + 5 && right-left >= 4*size+1 - lift.lift $ drawStateWithGeom [] False Map.empty (snd lock) (CVec hcentre vcentre,origin) + _ <- lift.lift $ drawStateWithGeom [] False Map.empty (snd lock) (CVec hcentre vcentre,origin) return (hcentre - size - 1, hcentre + size + 1) , lift $ do drawActiveLock (CVec hcentre vcentre) al @@ -159,13 +158,13 @@ else if any (\(Undeclared _ ls _) -> ls == lockSpec lockinfo) undecls then lift $ drawStrCentred a0 yellow (CVec (lockBottom+1) vcentre) "Undeclared solution!" else do - read <- take 3 <$> getNotesReadOn lockinfo - unless (null read || ourName == Just name) $ do + readNotes <- take 3 <$> getNotesReadOn lockinfo + unless (null readNotes || ourName == Just name) $ do let rntext = if right-left > 30 then "Read notes by:" else "Notes:" s = vcentre - (length rntext+(3+1)*3)`div`2 lift $ drawStr a0 white (CVec (lockBottom+1) s) rntext void $ fillBox (CVec (lockBottom+1) (s+length rntext+1)) (CVec (lockBottom+1) right) 3 GravLeft - [ \pos -> drawName False pos name | name <- noteAuthor <$> read ] + [ \pos -> drawName False pos name' | name' <- noteAuthor <$> readNotes ] lift $ drawStrCentred a0 white (CVec (lockBottom+2) vcentre) "Notes held:" if null $ notesSecured lockinfo @@ -173,7 +172,7 @@ drawStrCentred a0 white (CVec (lockBottom+3) vcentre) "None" else void $ fillBox (CVec (lockBottom+3) (left+1)) (CVec bottom (right-1)) 5 GravUp - [ (`drawActiveLock` al) | al <- noteOn <$> notesSecured lockinfo ] + [ (`drawActiveLock` al') | al' <- noteOn <$> notesSecured lockinfo ] data HelpReturn = HelpNone | HelpDone | HelpContinue Int @@ -185,7 +184,7 @@ HelpDone -> return True HelpContinue from' -> do drawPrompt False "[MORE]" - getInput IMTextInput + _ <- getInput IMTextInput showHelpPaged from' mode page showHelpPaged' :: Int -> InputMode -> HelpPage -> UIM HelpReturn showHelpPaged' from mode HelpPageInput = do @@ -203,10 +202,10 @@ keysStr ++ replicate pad ' ' ++ ": " ++ desc | ((keysStr,pad,desc),(x,y)) <- zip [ (keysStr,pad,desc) - | group <- groups - , let cmd = snd $ head group + | grp <- groups + , let cmd = snd $ head grp , let desc = describeCommand cmd - , let chs = fst <$> group + , let chs = fst <$> grp , let keysStr = showKeys chs , let pad = max 0 $ min (maxkeyslen + 1 - length keysStr) $ bdgWidth - length desc - length keysStr - 1 - 1 @@ -235,15 +234,15 @@ if w >= maximum (length <$> metagameHelpText) then body else - let wrap max = wrap' max max + let wrap mx = wrap' mx mx 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 + wrap' mx left (wd:wds) = if 1+length wd > left + then if left == mx + then take mx wd ++ "\n" ++ + wrap' mx mx (drop mx wd : wds) + else '\n' : wrap' mx mx (wd:wds) + else let prepend = if left == mx then wd else ' ':wd + in prepend ++ wrap' mx (left - length prepend) wds in lines . wrap w . words $ unwords body top = max 0 $ (h - length strs) `div` 2 drawStrCentred a0 titleCol (CVec top $ w`div`2) title @@ -289,19 +288,19 @@ lift refresh where drawMainState' PlayState { psCurrentState=st, psLastAlerts=alerts, - wrenchSelected=wsel, psFrame=frame, psTutLevel=tutLevel } = lift $ do + wrenchSelected=wsel, psFrame=frame, psTutLevel=tutLev } = lift $ do drawState [] False alerts st drawBindingsTables IMPlay filterBindings frame drawCursorAt $ listToMaybe [ pos | (_, PlacedPiece pos p) <- enumVec $ placedPieces st , (wsel && isWrench p) || (not wsel && isHook p) ] where - filterBindings (CmdRotate _ _) = not $ wrenchOnlyTutLevel tutLevel - filterBindings CmdUndo = not $ noUndoTutLevel tutLevel - filterBindings CmdRedo = not $ noUndoTutLevel tutLevel - filterBindings CmdMark = not $ noUndoTutLevel tutLevel - filterBindings CmdJumpMark = not $ noUndoTutLevel tutLevel - filterBindings CmdReset = not $ noUndoTutLevel tutLevel + filterBindings (CmdRotate _ _) = not $ wrenchOnlyTutLevel tutLev + filterBindings CmdUndo = not $ noUndoTutLevel tutLev + filterBindings CmdRedo = not $ noUndoTutLevel tutLev + filterBindings CmdMark = not $ noUndoTutLevel tutLev + filterBindings CmdJumpMark = not $ noUndoTutLevel tutLev + filterBindings CmdReset = not $ noUndoTutLevel tutLev filterBindings _ = True drawMainState' ReplayState {} = do lift . drawState [] False [] =<< gets rsCurrentState @@ -311,7 +310,7 @@ drawState (maybeToList selPiece) True [] st drawBindingsTables IMEdit (const True) frame drawCursorAt $ if isNothing selPiece then Just selPos else Nothing - drawMainState' InitState {initLocks=initLocks, tutProgress=TutProgress{tutSolved=tutSolved}} = lift $ do + drawMainState' InitState {initLocks=iLocks, tutProgress=TutProgress{tutSolved=tSolved}} = lift $ do drawCursorAt Nothing (h,w) <- liftIO Curses.scrSize when (h<15 || w<30) $ liftIO CursesH.end >> error "Terminal too small!" @@ -323,32 +322,31 @@ doDrawAt (centre +^ CVec 7 0) . alignDraw GravCentre 0 $ bindingsDraw bdgs [CmdQuit] <> greyDraw " quit" let cvec v = clampHoriz $ centre +^ CVec y (3*x-1) where CVec y x = hexVec2CVec v - clampHoriz (CVec y x) = CVec y . max 0 $ min (w-4) x + clampHoriz (CVec y' x') = CVec y' . max 0 $ min (w-4) x' drawInitLock v = do let pos = tutPos +^ 2 *^ v drawStr bold (if solved v then green else red) (cvec pos) (name v) sequence_ - [ drawStr a0 green (cvec $ pos +^ h) str - | (h,str) <- [(hu,"---"), (neg hv," \\ "), (neg hw," / ")] - , let v' = v +^ h + [ drawStr a0 green (cvec $ pos +^ h') str + | (h',str) <- [(hu,"---"), (neg hv," \\ "), (neg hw," / ")] + , let v' = v +^ h' , abs (hy v') < 2 && hx v' >= 0 && hz v' <= 0 - , v' `Map.member` accessible || (isLast v && h == hu) + , v' `Map.member` accessible || (isLast v && h' == hu) , solved v || solved v' ] drawInitLock zero mapM_ drawInitLock $ Map.keys accessible where - accessible = accessibleInitLocks tutSolved initLocks + accessible = accessibleInitLocks tSolved iLocks tutPos = maximumBound 0 (hx <$> Map.keys accessible) *^ neg hu name v | v == zero = "TUT" | otherwise = maybe "???" initLockName $ Map.lookup v accessible - solved v | v == zero = tutSolved + solved v | v == zero = tSolved | otherwise = Just True == (initLockSolved <$> Map.lookup v accessible) isLast v | v == zero = False | otherwise = Just True == (isLastInitLock <$> Map.lookup v accessible) drawMainState' MetaState {curServer=saddr, undeclareds=undecls, cacheOnly=cOnly, curAuth=auth, codenameStack=names, - randomCodenames=rnamestvar, retiredLocks=mretired, curLockPath=path, - curLock=lock} = do + randomCodenames=rnamestvar, retiredLocks=mretired, curLockPath=path } = do modify $ \ms -> ms { listOffsetMax = True } let ourName = authUser <$> auth let selName = listToMaybe names @@ -368,7 +366,7 @@ 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] + CmdSelectLock : if path == "" then [] else [CmdNextLock, CmdPrevLock, CmdDeleteLock] lockTextDraw = greyDraw . take (w - leftBdgsWidth - drawWidth lockBdgsDraw' - 1) $ " Lock: " ++ path ++ replicate 5 ' ' doDrawAt (CVec 0 0) $ alignDraw GravLeft leftBdgsWidth serverBdgsDraw <> serverTextDraw @@ -379,18 +377,17 @@ maybe (return ()) (drawName True (CVec 2 (w`div`2))) selName void.runMaybeT $ MaybeT (return selName) >>= lift . getUInfoFetched 300 >>= - \(FetchedRecord fresh err muirc) -> lift $ do + \(FetchedRecord isFresh err muirc) -> lift $ do lift $ do - unless fresh $ drawAtCVec (Glyph '*' red bold) $ CVec 2 (w`div`2+7) + unless isFresh $ drawAtCVec (Glyph '*' red bold) $ CVec 2 (w`div`2+7) maybe (return ()) sayError err - when (fresh && (isNothing ourName || home || isNothing muirc)) $ + when (isFresh && (isNothing ourName || home || isNothing muirc)) $ doDrawAt (CVec 2 (w`div`2+1+9)) $ bindingsDraw bdgs $ if (isNothing muirc && isNothing ourName) || home - then [CmdRegister $ isJust ourName] else [CmdAuth] + then [CmdRegister] 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 $ doDrawAt (CVec 5 (w`div`3)) $ bindingsDraw bdgs $ @@ -452,10 +449,11 @@ drawAlert (AlertCollision pos) = drawAt cGlyph pos drawAlert _ = return () cGlyph = Glyph '!' 0 a0 + onPhysicsTick = pure () clearMessage = say "" drawMessage = say - drawPrompt full s = liftIO (void $ Curses.cursSet Curses.CursorVisible) >> say s + drawPrompt _ s = liftIO (void $ Curses.cursSet Curses.CursorVisible) >> say s endPrompt = say "" >> liftIO (void $ Curses.cursSet Curses.CursorInvisible) drawError = sayError @@ -503,17 +501,19 @@ impatience ticks = do when (ticks>20) $ say "Waiting for server (^C to abort)..." unblock <- unblockInput - liftIO $ forkIO $ threadDelay 50000 >> unblock + _ <- liftIO $ forkIO $ threadDelay 50000 >> unblock cmds <- getInput IMImpatience return $ CmdQuit `elem` cmds + getInputNoBlock _ = pure [] + getInput mode = do let userResizeCode = 1337 -- XXX: chosen not to conflict with HSCurses codes key <- liftIO $ CursesH.getKey (Curses.ungetCh userResizeCode) >>= handleEsc if key == Curses.KeyUnknown userResizeCode then do - liftIO Curses.scrSize + _ <- liftIO Curses.scrSize return [CmdRedraw] else do let mch = charify key diff --git a/Database.hs b/Database.hs --- a/Database.hs +++ b/Database.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -14,7 +14,10 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Reader +import qualified Data.Binary as B +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as CS +import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as CL import Data.Char (toUpper) import Data.Maybe @@ -52,6 +55,7 @@ | RecServerEmail | RecPublicKey | RecSecretKey + | RecIsSuperuser Codename deriving (Eq, Ord, Show) data RecordContents = RCPasswordLegacy Password @@ -66,6 +70,7 @@ | RCEmail CS.ByteString | RCPublicKey PublicKey | RCSecretKey PrivateKey + | RCIsSuperuser Bool deriving (Eq, Show) rcOfServerResp (ServedServerInfo x) = RCServerInfo x @@ -100,6 +105,28 @@ recordExists :: Record -> DBM Bool recordExists rec = recordPath rec >>= liftIO . doesFileExist +-- |try to decode binary format, falling back to legacy Read format on failure +tryGetBinary :: (B.Binary a, Read a) => Handle -> IO (Maybe a) +tryGetBinary h = tryDecode . BL.fromStrict <$> hGetContentsNoClose h + where + tryDecode :: (B.Binary a, Read a) => BL.ByteString -> Maybe a + tryDecode c = + case B.decodeOrFail c of + Right (_,_,a) -> Just a + Left _ -> tryRead $ CS.unpack $ BL.toStrict c + +hGetStrict h = CS.unpack <$> hGetContentsNoClose h + +hGetContentsNoClose :: Handle -> IO BS.ByteString +hGetContentsNoClose h = concatMWhileNonempty (repeat $ BS.hGet h 1024) + where + concatMWhileNonempty (m:ms) = do + bs <- m + if BS.null bs + then return bs + else (bs `BS.append`) <$> concatMWhileNonempty ms + concatMWhileNonempty [] = pure BS.empty + getRecord :: Record -> DBM (Maybe RecordContents) getRecord rec = do path <- recordPath rec @@ -109,23 +136,17 @@ getRecordh (RecPasswordLegacy _) h = (RCPasswordLegacy <$>) . tryRead <$> hGetStrict h getRecordh (RecPasswordArgon2 _) h = (RCPasswordArgon2 <$>) . tryRead <$> hGetStrict h getRecordh (RecEmail _) h = (RCEmail <$>) . tryRead <$> hGetStrict h -getRecordh (RecUserInfo _) h = (RCUserInfo <$>) . tryRead <$> hGetStrict h -getRecordh (RecUserInfoLog _) h = (RCUserInfoDeltas <$>) . tryRead <$> hGetStrict h +getRecordh (RecUserInfo _) h = (RCUserInfo <$>) <$> tryGetBinary h +getRecordh (RecUserInfoLog _) h = (RCUserInfoDeltas <$>) <$> tryGetBinary h getRecordh (RecLock _) h = (RCLock <$>) . tryRead <$> hGetStrict h getRecordh (RecNote _) h = (RCSolution <$>) . tryRead <$> hGetStrict h getRecordh RecLockHashes h = (RCLockHashes <$>) . tryRead <$> hGetStrict h -getRecordh (RecRetiredLocks name) h = (RCLockSpecs <$>) . tryRead <$> hGetStrict h +getRecordh (RecRetiredLocks _) 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 - bs <- m - if CS.null bs - then return bs - else (bs `CS.append`) <$> concatMWhileNonempty ms +getRecordh (RecIsSuperuser _) h = (RCIsSuperuser <$>) . tryRead <$> hGetStrict h putRecord :: Record -> RecordContents -> DBM () putRecord rec rc = do @@ -138,8 +159,8 @@ putRecordh (RCPasswordLegacy hpw) h = hPutStr h $ show hpw putRecordh (RCPasswordArgon2 hpw) h = hPutStr h $ show hpw putRecordh (RCEmail addr) h = hPutStr h $ show addr -putRecordh (RCUserInfo info) h = hPutStr h $ show info -putRecordh (RCUserInfoDeltas deltas) h = hPutStr h $ show deltas +putRecordh (RCUserInfo info) h = BL.hPut h $ B.encode info +putRecordh (RCUserInfoDeltas deltas) h = BL.hPut h $ B.encode deltas putRecordh (RCLock lock) h = hPutStr h $ show lock putRecordh (RCSolution solution) h = hPutStr h $ show solution putRecordh (RCLockHashes hashes) h = hPutStr h $ show hashes @@ -147,6 +168,7 @@ putRecordh (RCServerInfo sinfo) h = hPutStr h $ show sinfo putRecordh (RCPublicKey publicKey) h = hPutStr h $ show publicKey putRecordh (RCSecretKey secretKey) h = hPutStr h $ show secretKey +putRecordh (RCIsSuperuser super) h = hPutStr h $ show super modifyRecord :: Record -> (RecordContents -> RecordContents) -> DBM () modifyRecord rec f = do @@ -198,6 +220,7 @@ recordPath' RecServerEmail = "serverEmail" recordPath' RecPublicKey = "publicKey" recordPath' RecSecretKey = "secretKey" + recordPath' (RecIsSuperuser name) = userDir name ++ "superuser" userDir name = "users" ++ [pathSeparator] ++ pathifyName name ++ [pathSeparator] alockFN (ActiveLock name idx) = pathifyName name ++":"++ show idx diff --git a/EditGameState.hs b/EditGameState.hs --- a/EditGameState.hs +++ b/EditGameState.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -12,9 +12,7 @@ import Control.Applicative import Control.Monad -import Data.Function (on) import Data.List -import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe diff --git a/Font.hs b/Font.hs new file mode 100644 --- /dev/null +++ b/Font.hs @@ -0,0 +1,19 @@ +-- This file is part of Intricacy +-- Copyright (C) 2013-2025 Martin Bays +-- +-- 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/. + +{-# LANGUAGE TemplateHaskell #-} + +module Font where + +import qualified Data.ByteString as BS +import Data.FileEmbed (embedFile) + +veraMoBd :: BS.ByteString +veraMoBd = $(embedFile "VeraMoBd.ttf") diff --git a/Frame.hs b/Frame.hs --- a/Frame.hs +++ b/Frame.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -76,7 +76,7 @@ checkEditable :: Frame -> HexPos -> HexPos -> HexPos checkEditable f def pos = if inEditable f pos then pos else def truncateToBounds,truncateToEditable :: Frame -> HexPos -> HexPos -truncateToBounds f pos@(PHS v) = PHS $ truncateToLength (frameSize f - 1) v +truncateToBounds f (PHS v) = PHS $ truncateToLength (frameSize f - 1) v truncateToEditable f pos@(PHS v) = if inBounds f pos then pos else head diff --git a/GameState.hs b/GameState.hs --- a/GameState.hs +++ b/GameState.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -22,7 +22,7 @@ import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set -import Data.Vector (Vector, (!), (//)) +import Data.Vector ((!), (//)) import qualified Data.Vector as Vector import GameStateTypes @@ -62,15 +62,15 @@ in ( (c, Set.map (+^ neg c) comp) : components patt' ) floodfill :: HexVec -> Set HexVec -> (Set HexVec, Set HexVec) -floodfill start patt = floodfill' start `execState` (patt, Set.empty) +floodfill start initPatt = floodfill' start `execState` (initPatt, Set.empty) where floodfill' :: HexVec -> State (Set HexVec, Set HexVec) () - floodfill' start = do + floodfill' base = do (patt, dels) <- get - let patt' = Set.delete start patt + let patt' = Set.delete base patt unless (Set.size patt' == Set.size patt) $ do - put (patt', Set.insert start dels) - sequence_ [ floodfill' (dir+^start) | dir <- hexDirs ] + put (patt', Set.insert base dels) + sequence_ [ floodfill' (dir+^base) | dir <- hexDirs ] delPiece :: PieceIdx -> GameState -> GameState delPiece idx (GameState pps conns) = @@ -195,7 +195,7 @@ in case p of Block patt -> let comps = components $ Set.fromList patt - ppOfComp (v,patt) = PlacedPiece (v+^ppos) $ Block $ Set.toList patt + ppOfComp (v,patt') = PlacedPiece (v+^ppos) $ Block $ Set.toList patt' in case comps of [] -> (delPiece idx st, Nothing) zeroComp:newComps -> @@ -303,7 +303,7 @@ castRay :: HexPos -> HexDir -> GameBoard -> Maybe (PieceIdx, HexPos) castRay start dir board = - castRay' 30 start + castRay' (30::Int) start where castRay' 0 _ = Nothing castRay' n pos = case Map.lookup pos board of @@ -324,7 +324,7 @@ && springExtensionValid st c && validRoot st root && validEnd st end - | c@(Connection root@(ridx,_) end@(eidx,_) (Spring dir _)) <- conns + | c@(Connection root@(_,_) end@(eidx,_) (Spring dir _)) <- conns , let [rpos,epos] = locusPos st <$> [root,end] ] , and [ 1 == length (components $ Set.fromList patt) | Block patt <- placedPiece <$> Vector.toList pps ] diff --git a/GameStateTypes.hs b/GameStateTypes.hs --- a/GameStateTypes.hs +++ b/GameStateTypes.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 diff --git a/GraphColouring.hs b/GraphColouring.hs --- a/GraphColouring.hs +++ b/GraphColouring.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -11,15 +11,11 @@ module GraphColouring (fiveColour) where import Data.List -import Data.Map (Map) -import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Vector as Vector type Colouring a = Map a Int -type Graph a = (Set a, Set (Set a)) type PlanarGraph a = Map a [a] fiveColour :: Ord a => PlanarGraph a -> Colouring a -> Colouring a @@ -42,7 +38,7 @@ , e <- g Map.! s ] fiveColour' :: Ord a => Colouring a -> PlanarGraph a -> Colouring a -fiveColour' pref g | g == Map.empty = Map.empty +fiveColour' _ g | g == Map.empty = Map.empty fiveColour' pref g = let adjsOf v = nub (g Map.! v) \\ [v] v0 = head $ filter ((<=5) . length . adjsOf) $ Map.keys g diff --git a/Hex.lhs b/Hex.lhs --- a/Hex.lhs +++ b/Hex.lhs @@ -155,7 +155,7 @@ l = hexLen v lv' = (`div`l) . (n*) <$> [x,y,z] minI = fst $ minimumBy (compare `on` snd) $ - zip [0..] $ abs <$> lv' + zip [0::Int ..] $ abs <$> lv' [x'',y'',z''] = zipWith (-) lv' [ d | i <- [0..2] , let d = if i == minI then sum lv' else 0 ] diff --git a/Init.hs b/Init.hs --- a/Init.hs +++ b/Init.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -8,8 +8,9 @@ -- 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 Init where +{-# LANGUAGE CPP #-} +module Init where import Control.Applicative import Control.Monad @@ -26,21 +27,24 @@ import Interact import Lock import MainState -import Mundanities import Util import Version data Opt = DataDir FilePath | LockSize Int +#ifdef CURSES | ForceCurses +#endif | Help | Version deriving (Eq, Ord, Show) options = [ Option ['d'] ["datadir"] (ReqArg DataDir "PATH") "user data and conf directory (default: ~/.intricacy)" +#ifdef CURSES , Option ['c'] ["curses"] (NoArg ForceCurses) "force curses UI" +#endif , Option ['s'] ["locksize"] (ReqArg (LockSize . read) "SIZE") "locksize" , Option ['h'] ["help"] (NoArg Help) "show usage information" , Option ['v'] ["version"] (NoArg Version) "show version information" @@ -62,7 +66,7 @@ (opts,args) <- parseArgs argv when (Help `elem` opts) $ putStr usage >> exitSuccess when (Version `elem` opts) $ putStrLn version >> exitSuccess - let size = fromMaybe 8 $ listToMaybe [ size | LockSize size <- opts ] + let size = fromMaybe 8 $ listToMaybe [ lsize | LockSize lsize <- opts ] mapM_ (setEnv "INTRICACY_PATH") [ dir | DataDir dir <- opts ] curDir <- getCurrentDirectory @@ -79,14 +83,20 @@ Maybe (s MainState -> IO (Maybe MainState)) -> Maybe (c MainState -> IO (Maybe MainState)) -> IO () main' msdlUI mcursesUI = do +#ifdef CURSES (mlock,opts,mpath) <- setup +#else + (mlock,_,mpath) <- setup +#endif initMState <- case mlock of Just (lock, msoln) -> return $ newEditState lock msoln mpath Nothing -> initMetaState void $ runMaybeT $ msum [ do finalState <- msum [ do +#ifdef CURSES guard $ ForceCurses `notElem` opts +#endif sdlUI <- liftMaybe msdlUI MaybeT $ sdlUI $ interactUI `execStateT` initMState , do diff --git a/InputMode.hs b/InputMode.hs --- a/InputMode.hs +++ b/InputMode.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 diff --git a/Interact.hs b/Interact.hs --- a/Interact.hs +++ b/Interact.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -16,6 +16,7 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.STM +import Control.Monad import Control.Monad.Catch import Control.Monad.State import Control.Monad.Trans.Except @@ -23,14 +24,10 @@ import Control.Monad.Writer import Data.Array import qualified Data.ByteString.Char8 as CS -import qualified Data.ByteString.Lazy as BL import Data.Char -import Data.Function (on) import Data.List -import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe -import qualified Data.Vector as Vector import Safe (readMay) import System.Directory import System.FilePath @@ -71,9 +68,11 @@ lift $ onNewMode im when (im == IMEdit) setSelectedPosFromMouse when (im == IMMeta) $ do - spawnUnblockerThread + _ <- spawnUnblockerThread - -- draw before testing auth, lest a timeout mean a blank screen + -- process resizes and draw before testing auth, lest a timeout mean a blank screen + cmds <- lift $ getInputNoBlock im + _ <- runExceptT (mapM_ (processCommand im) cmds) drawMainState testAuth @@ -118,11 +117,11 @@ (InteractSuccess complete, s) <- runSubMainState =<< liftIO initInitState liftIO $ writeInitState s when complete $ do - modify $ \s -> s {initiated = True} + modify $ \s' -> s' {initiated = True} mauth <- gets curAuth when (isNothing mauth) $ do cbdg <- lift $ getUIBinding IMMeta $ CmdSelCodename Nothing - rbdg <- lift $ getUIBinding IMMeta (CmdRegister False) + rbdg <- lift $ getUIBinding IMMeta CmdRegister let showPage p prompt = lift $ withNoBG $ showHelp IMMeta p >>? do void $ textInput prompt 1 False True Nothing Nothing showPage (HelpPageInitiated 1) "[Initiation complete. Press a key or RMB to continue]" @@ -132,10 +131,6 @@ "To join the game: pick a codename ('"++cbdg++ "') and register it ('"++rbdg++"')." -getSomeInput im = do - cmds <- getInput im - if null cmds then getSomeInput im else return cmds - processCommand :: UIMonad uiM => InputMode -> Command -> ExceptT InteractSuccess (MainStateT uiM) () processCommand im CmdQuit = do case im of @@ -146,9 +141,12 @@ title <- lift getTitle (lift . lift . confirm) ("Really quit" ++ (if im == IMEdit then " without saving" else "") - ++ maybe "" ((" from "++) . fst) title ++ "?") + ++ maybe "" ((" from "++) . lowerFirstChar . fst) title ++ "?") >>? throwE $ InteractSuccess False -processCommand im CmdForceQuit = throwE $ InteractSuccess False + where + lowerFirstChar (c:cs) = toLower c : cs + lowerFirstChar "" = "" +processCommand _ CmdForceQuit = throwE $ InteractSuccess False processCommand IMPlay CmdOpen = do st <- gets psCurrentState frame <- gets psFrame @@ -157,8 +155,8 @@ else lift.lift $ drawError "Locked!" processCommand IMInit (CmdSolveInit Nothing) = void.runMaybeT $ do - tutSolved <- lift . gets $ tutSolved . tutProgress - accessible <- lift . gets $ accessibleInitLocks tutSolved . initLocks + tSolved <- lift . gets $ tutSolved . tutProgress + accessible <- lift . gets $ accessibleInitLocks tSolved . initLocks v <- if Map.null accessible then return zero else do let nameMap = Map.fromList $ ("TUT",zero) : [(initLockName l, v) | (v,l) <- Map.toList accessible] @@ -183,12 +181,14 @@ let pref = tutdir ++ [pathSeparator] ++ name (lock,_) <- MaybeT $ liftIO $ readLock (pref ++ ".lock") text <- liftIO $ fromMaybe "" . listToMaybe <$> readStrings (pref ++ ".text") - solveLockSaving i msps (Just i) lock $ Just $ "Tutorial " ++ show i ++ ": " ++ text + solved <- (isJust <$>) . lift $ solveLockSaving i msps (Just i) lock $ Just $ "Tutorial " ++ show i ++ ": " ++ text + lift $ liftIO . writeInitState =<< get + guard solved if i+1 <= length tuts then dotut (i+1) Nothing else lift $ do modify $ \is -> is {tutProgress = TutProgress True 1 Nothing} - lift $ drawMessage "Tutorial complete!" + lift $ drawMessage "Tutorial complete! Choose next lock to attempt." TutProgress _ onLevel msps <- lift $ gets tutProgress dotut onLevel msps processCommand IMInit (CmdSolveInit (Just v)) = void.runMaybeT $ do @@ -200,6 +200,7 @@ let updateLock initLock = initLock { initLockSolved = initLockSolved initLock || solved , initLockPartial = Just $ savePlayState ps } lift . modify $ \is -> is { initLocks = Map.adjust updateLock v $ initLocks is } + lift $ liftIO . writeInitState =<< get when (solved && isLastInitLock l) . throwE $ InteractSuccess True processCommand im cmd = lift $ processCommand' im cmd @@ -248,16 +249,15 @@ 1 False True (Just $ (:[]) <$> marks) Nothing ch <- liftMaybe $ listToMaybe str lift $ jumpMark ch -processCommand' im CmdReset = jumpMark startMark +processCommand' _ CmdReset = jumpMark startMark processCommand' IMMeta CmdInitiation = doInitiation processCommand' IMMeta (CmdSelCodename mname) = void.runMaybeT $ do - mauth <- gets curAuth name <- msum [ liftMaybe mname , do newCodename <- (map toUpper <$>) $ MaybeT $ lift $ textInput "Select codename:" - 3 False False Nothing Nothing + 3 False True Nothing Nothing guard $ length newCodename == 3 return newCodename ] @@ -301,7 +301,7 @@ unless newCOnly $ invalidateAllUInfo >> invalidateAllIndexedLocks -processCommand' IMMeta (CmdRegister _) = void.runMaybeT $ do +processCommand' IMMeta CmdRegister = void.runMaybeT $ do regName <- mgetCurName mauth <- gets curAuth let isUs = maybe False ((==regName).authUser) mauth @@ -326,7 +326,7 @@ setNotifications ] else msum [ do - mgetUInfo regName + _ <- mgetUInfo regName lift.lift $ drawError "Sorry, this codename is already taken." , do confirmOrBail $ "Register codename " ++ regName ++ "?" @@ -384,20 +384,22 @@ undecls <- lift (gets undeclareds) msum [ do undecl <- liftMaybe $ find (\(Undeclared _ ls' _) -> ls == ls') undecls - MaybeT $ gets curAuth + _ <- MaybeT $ gets curAuth confirmOrBail "Declare existing solution?" void.lift.runMaybeT $ -- ignores MaybeT failures declare undecl , do RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls mpartial <- gets (Map.lookup ls . partialSolutions) - soln <- solveLockSaving ls mpartial Nothing lock $ Just $ - "solving " ++ name ++ ":" ++ [lockIndexChar idx] ++ " (#" ++ show ls ++")" + msoln <- lift $ solveLockSaving ls mpartial Nothing lock $ Just $ + "Solving " ++ name ++ ":" ++ [lockIndexChar idx] ++ " (#" ++ show ls ++")" + lift $ liftIO . writeMetaState =<< get + soln <- MaybeT $ pure msoln mourName <- lift $ gets ((authUser <$>) . curAuth) guard $ mourName /= Just name let undecl = Undeclared soln ls (ActiveLock name idx) msum [ do - MaybeT $ gets curAuth + _ <- MaybeT $ gets curAuth confirmOrBail "Declare solution?" declare undecl , unless (any (\(Undeclared _ ls' _) -> ls == ls') undecls) $ @@ -411,7 +413,7 @@ liftMaybe $ readMay tls ] RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls - solveLock lock Nothing $ Just $ "solving " ++ show ls + solveLock lock Nothing $ Just $ "Solving " ++ show ls processCommand' IMMeta (CmdDeclare mundecl) = void.runMaybeT $ do guard =<< mourNameSelected @@ -440,7 +442,7 @@ ] processCommand' IMMeta (CmdViewSolution mnote) = void.runMaybeT $ do note <- liftMaybe mnote `mplus` do - ourName <- mgetOurName + _ <- mgetOurName name <- mgetCurName uinfo <- mgetUInfo name noteses <- lift $ sequence @@ -480,22 +482,47 @@ ourUInfo <- mgetUInfo ourName idx <- (liftMaybe midx `mplus`) $ askLockIndex ("Place " ++ show lockpath ++ " in which slot?") "bug" $ const True - when (isJust $ userLocks ourUInfo ! idx) $ - confirmOrBail "Really retire existing lock?" - soln <- (liftMaybe msoln `mplus`) $ solveLock lock Nothing $ Just "testing lock" + case userLocks ourUInfo ! idx of + Nothing -> pure () + Just lockInfo + -> confirmOrBail . concat $ ["Really retire existing lock?"] <> + [ " Your " <> show n <> " notes would become public." + | let n = length (notesSecured lockInfo), n > 0 ] + soln <- (liftMaybe msoln `mplus`) $ solveLock lock Nothing $ Just "Testing lock" lift $ curServerActionAsyncThenInvalidate (SetLock lock idx soln) (Just (SomeCodenames [ourName])) +processCommand' IMMeta CmdRetireLock = void.runMaybeT $ do + name <- mgetCurName + uinfo <- mgetUInfo name + idx <- askLockIndex "Retire which lock?" "No lock to retire!" (isJust . (userLocks uinfo !)) + case userLocks uinfo ! idx of + Nothing -> mzero + Just lockInfo -> + confirmOrBail . concat $ ["Really retire " ++ name ++ ":" ++ [lockIndexChar idx] ++ "?"] <> + [ " " <> show n <> " notes would become public." + | let n = length (notesSecured lockInfo), n > 0 ] + lift $ curServerActionAsyncThenInvalidate + (RetireLock $ ActiveLock name idx) + (Just (SomeCodenames [name])) + processCommand' IMMeta CmdSelectLock = void.runMaybeT $ do lockdir <- liftIO $ confFilePath "locks" paths <- liftIO $ map (drop (length lockdir + 1)) <$> getDirContentsRec lockdir - path <- MaybeT $ lift $ textInput "Lock name:" 1024 False False (Just paths) Nothing + let prompt = concat $ ["Lock name"] <> [ " [tab to complete]" | not $ null paths ] <> [":"] + path <- MaybeT $ lift $ textInput prompt 1024 False False (Just paths) Nothing lift $ setLockPath path processCommand' IMMeta CmdNextLock = gets curLockPath >>= liftIO . nextLock True >>= setLockPath processCommand' IMMeta CmdPrevLock = gets curLockPath >>= liftIO . nextLock False >>= setLockPath +processCommand' IMMeta CmdDeleteLock = void.runMaybeT $ do + lockpath <- lift $ gets curLockPath + confirmOrBail $ "Really delete lock \"" <> lockpath <> "\"?" + lift $ processCommand' IMMeta CmdNextLock + liftIO $ removeFile =<< fullLockPath lockpath + processCommand' IMMeta CmdNextPage = gets listOffsetMax >>! modify $ \ms -> ms { listOffset = listOffset ms + 1 } @@ -505,7 +532,6 @@ (lock, msoln) <- MaybeT (gets curLock) `mplus` do size <- msum [ do - gets curServer RCServerInfo (ServerInfo size _) <- MaybeT $ getFreshRecBlocking RecServerInfo return size , do @@ -539,7 +565,6 @@ lift $ modify $ \ms -> ms {retiredLocks = newRL} processCommand' IMPlay CmdUndo = do - st <- gets psCurrentState stack <- gets psGameStateMoveStack ustms <- gets psUndoneStack unless (null stack) $ do @@ -556,39 +581,70 @@ pushPState (st',pm) modify $ \ps -> ps {psLastAlerts = alerts, psUndoneStack = ustms'} processCommand' IMPlay (CmdManipulateToolAt pos) = do - board <- gets (stateBoard . psCurrentState) + st <- gets psCurrentState wsel <- gets wrenchSelected - void.runMaybeT $ msum $ (do - tile <- liftMaybe $ snd <$> Map.lookup pos board - guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False} - lift $ processCommand' IMPlay $ CmdTile tile) : [ do - tile <- liftMaybe $ snd <$> Map.lookup (d+^pos) board - guard $ tileType tile == if wsel then WrenchTile zero else HookTile + let board = stateBoard st + let isSel (_, tile) = tileType tile == if wsel then WrenchTile zero else HookTile + isHookTile (_, HookTile) = True + isHookTile _ = False + isSelArm (idx, ArmTile _ _) + | PlacedPiece _ (Hook _ _) <- getpp st idx = not wsel + isSelArm _ = False + getAt pos' = liftMaybe $ Map.lookup pos' board + select = (lift . processCommand' IMPlay . CmdTile =<<) $ + getAt pos >>= \case + (idx, ArmTile _ _) | PlacedPiece _ (Hook _ _) <- getpp st idx -> pure HookTile + (_, tile@(WrenchTile _)) -> pure tile + (_, tile@HookTile) -> pure tile + _ -> mzero + rot = [ do + getAt (d+^pos) >>= guard . isHookTile + getAt (rotated+^d+^pos) >>= guard . isSelArm + lift $ processCommand' IMPlay $ CmdRotate WHSHook r + | d <- hexDirs + , r <- [-1,1] + , let rotated = rotate (-r) (neg d) + ] + goDirs p = [ do + getAt (d+^pos) >>= guard . p lift $ processCommand' IMPlay $ CmdDir WHSSelected $ neg d | d <- hexDirs ] + void.runMaybeT $ msum $ select : rot <> goDirs isSel <> goDirs isSelArm processCommand' IMPlay (CmdDrag pos dir) = do - board <- gets (stateBoard . psCurrentState) + st <- gets psCurrentState + let board = stateBoard st wsel <- gets wrenchSelected - void.runMaybeT $ do - tp <- liftMaybe $ tileType . snd <$> Map.lookup pos board - msum [ guard $ tp == HookTile - , do - guard $ tp == WrenchTile zero - board' <- lift $ gets ((stateBoard . fst . runWriter . physicsTick (WrenchPush dir)) . psCurrentState) - msum $ [ do - tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board' - guard $ tp' == WrenchTile zero - | d <- [0,1,2] - , let pos' = d *^ dir +^ pos ] - ++ [ (lift.lift $ warpPointer pos) >> mzero ] - ] - lift $ processCommand' IMPlay $ CmdDir WHSSelected dir - board' <- gets (stateBoard . psCurrentState) - msum [ do - tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board' - guard $ tp' == if wsel then WrenchTile zero else HookTile - lift.lift $ warpPointer pos' - | pos' <- (+^pos) <$> hexDisc 2 ] + void.runMaybeT $ liftMaybe (Map.lookup pos board) >>= \case + (idx, ArmTile arm _) | PlacedPiece hookPos (Hook _ _) <- getpp st idx -> do + rotDir <- liftMaybe $ listToMaybe [ r | r <- [-1,1], rotate r arm == arm +^ dir ] + lift $ processCommand' IMPlay $ CmdRotate WHSHook rotDir + board' <- gets (stateBoard . psCurrentState) + msum $ [ lift . lift $ warpPointer pos' + | arm' <- [arm, rotate rotDir arm] + , let pos' = arm' +^ hookPos + , Just (idx',ArmTile arm'' _) <- [Map.lookup pos' board'] + , idx' == idx + , arm'' == arm' + ] + (_, tile) -> do + msum [ guard $ tile == HookTile + , do + guard $ tileType tile == WrenchTile zero + board' <- lift $ gets ((stateBoard . fst . runWriter . physicsTick (WrenchPush dir)) . psCurrentState) + msum $ [ do + tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board' + guard $ tp' == WrenchTile zero + | d <- [0,1,2] + , let pos' = d *^ dir +^ pos ] + ++ [ (lift.lift $ warpPointer pos) >> mzero ] + ] + lift $ processCommand' IMPlay $ CmdDir WHSSelected dir + board' <- gets (stateBoard . psCurrentState) + msum [ do + tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board' + guard $ tp' == if wsel then WrenchTile zero else HookTile + lift.lift $ warpPointer pos' + | pos' <- (+^pos) <$> hexDisc 2 ] processCommand' IMPlay cmd = do wsel <- gets wrenchSelected @@ -597,11 +653,7 @@ | whs == WHSWrench || (whs == WHSSelected && wsel) = Just $ WrenchPush dir | otherwise = Just $ HookPush dir - torque whs dir - {- | whs == WHSHook || (whs == WHSSelected && not wsel)= - Just $ HookTorque dir - | otherwise = Nothing -} - = Just $ HookTorque dir + torque _ dir = Just $ HookTorque dir (wsel', pm) = case cmd of CmdTile (WrenchTile _) -> (True, Nothing) @@ -659,7 +711,7 @@ guard $ st' == st return soln void.runMaybeT $ do - soln <- solveLock (frame,st) curSoln $ Just $ "testing " ++ fromMaybe "[unnamed lock]" mpath + soln <- solveLock (frame,st) curSoln $ Just $ "Testing " ++ fromMaybe "[unnamed lock]" mpath lift $ modify $ \es -> es { esTested = Just (st, soln) } processCommand' IMEdit CmdUndo = do st <- gets esGameState @@ -731,7 +783,6 @@ paintTilePath frame tile (truncateToEditable frame from) (truncateToEditable frame to) processCommand' IMEdit CmdMerge = do selPos <- gets selectedPos - st <- gets esGameState lift $ drawMessage "Merge in which direction?" let getDir = do cmd <- lift $ head <$> getSomeInput IMEdit @@ -740,22 +791,19 @@ CmdDrag _ mergeDir -> return $ Just mergeDir CmdMoveTo _ -> getDir _ -> return Nothing - mergeDir <- getDir - case mergeDir of + mmergeDir <- getDir + case mmergeDir of Just mergeDir -> modifyEState $ mergeTiles selPos mergeDir True _ -> return () -- XXX: merging might invalidate selectedPiece modify $ \es -> es {selectedPiece = Nothing} lift clearMessage -processCommand' IMEdit CmdWait = do - st <- gets esGameState - (st',_) <- lift $ doPhysicsTick NullPM st - pushEState st' +processCommand' IMEdit CmdWait = + pushEState =<< (fst <$>) . lift . doPhysicsTick NullPM =<< gets esGameState processCommand' IMEdit CmdDelete = do selPos <- gets selectedPos selPiece <- gets selectedPiece - st <- gets esGameState case selPiece of Nothing -> drawTile selPos Nothing False Just p -> do modify $ \es -> es {selectedPiece = Nothing} @@ -780,10 +828,10 @@ processCommand' _ _ = return () inputPassword :: UIMonad uiM => Codename -> Bool -> String -> MaybeT (MainStateT uiM) String -inputPassword name confirm prompt = do +inputPassword name doConfirm prompt = do pw <- MaybeT $ lift $ textInput prompt 64 True False Nothing Nothing guard $ not $ null pw - when confirm $ do + when doConfirm $ do pw' <- MaybeT $ lift $ textInput "Confirm password:" 64 True False Nothing Nothing when (pw /= pw') $ do lift.lift $ drawError "Passwords don't match!" @@ -800,7 +848,7 @@ encryptPassword :: UIMonad uiM => PublicKey -> String -> String -> MaybeT (MainStateT uiM) String encryptPassword publicKey name password = MaybeT . liftIO . - handle (\(e :: SomeException) -> return Nothing) $ do + handle (\(_ :: SomeException) -> return Nothing) $ do Right c <- encrypt (defaultOAEPParams SHA256) publicKey . CS.pack $ hashed return . Just . CS.unpack $ c where hashed = hash $ "IY" ++ name ++ password @@ -819,24 +867,26 @@ solveLock :: UIMonad uiM => Lock -> Maybe Solution -> Maybe String -> MaybeT (MainStateT uiM) Solution solveLock = solveLock' Nothing -solveLock' tutLevel lock mSoln title = do +solveLock' tutLev lock mSoln title = do (InteractSuccess solved, ps) <- lift $ runSubMainState $ - newPlayState (reframe lock) (fromMaybe [] mSoln) title tutLevel False False + newPlayState (reframe lock) (fromMaybe [] mSoln) title tutLev False False guard solved return . reverse $ snd <$> psGameStateMoveStack ps -solveLockSaving :: UIMonad uiM => LockSpec -> Maybe SavedPlayState -> Maybe Int -> Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution -solveLockSaving ls msps tutLevel lock title = do - let isTut = isJust tutLevel +solveLockSaving :: UIMonad uiM => LockSpec -> Maybe SavedPlayState -> Maybe Int -> Lock -> Maybe String -> MainStateT uiM (Maybe Solution) +solveLockSaving ls msps tutLev lock title = runMaybeT $ do + let isTut = isJust tutLev (InteractSuccess solved, ps) <- lift $ runSubMainState $ - maybe newPlayState restorePlayState msps (reframe lock) [] title tutLevel False True + maybe newPlayState restorePlayState msps (reframe lock) [] title tutLev False True + let setTutProgress ms = ms { tutProgress = (tutProgress ms) { tutLevel = ls, tutPartial = Just $ savePlayState ps } } if solved then do - unless isTut . lift . modify $ \ms -> ms { partialSolutions = Map.delete ls $ partialSolutions ms } + lift $ modify $ \ms -> if isTut + then setTutProgress ms + else ms { partialSolutions = Map.delete ls $ partialSolutions ms } return . reverse $ snd <$> psGameStateMoveStack ps else do lift $ modify $ \ms -> if isTut - then ms { tutProgress = (tutProgress ms) - { tutLevel = ls, tutPartial = Just $ savePlayState ps } } + then setTutProgress ms else ms { partialSolutions = Map.insert ls (savePlayState ps) $ partialSolutions ms } mzero diff --git a/InteractUtil.hs b/InteractUtil.hs --- a/InteractUtil.hs +++ b/InteractUtil.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -11,6 +11,7 @@ module InteractUtil where import Control.Applicative +import Control.Monad import Control.Monad.State import Control.Monad.Trans.Maybe import Control.Monad.Writer @@ -18,7 +19,6 @@ import Data.Char import Data.Function (on) import Data.List -import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import System.Directory @@ -71,12 +71,12 @@ adjustSpringTension :: UIMonad uiM => PieceIdx -> Int -> MainStateT uiM () adjustSpringTension p dl = do st <- gets esGameState - let updateConn c@(Connection r e@(p',_) (Spring d l)) + let updateConn (Connection r e@(p',_) (Spring d l)) | p' == p , let c' = Connection r e (Spring d $ l + dl) , springExtensionValid st c' = c' - | otherwise = c + updateConn c = c pushEState $ st { connections = updateConn <$> connections st } pushEState :: UIMonad uiM => GameState -> MainStateT uiM () @@ -96,9 +96,11 @@ pushEState $ f st doPhysicsTick :: UIMonad uiM => PlayerMove -> GameState -> uiM (GameState, [Alert]) -doPhysicsTick pm st = - let r@(st',alerts) = runWriter $ physicsTick pm st in - reportAlerts st' alerts >> return r +doPhysicsTick pm st = do + let r@(st',alerts) = runWriter $ physicsTick pm st + reportAlerts st' alerts + onPhysicsTick + return r nextLock :: Bool -> FilePath -> IO FilePath nextLock newer path = do @@ -122,7 +124,7 @@ lock <- liftIO $ fullLockPath path >>= readLock modify $ \ms -> ms {curLockPath = path, curLock = lock} -declare undecl@(Undeclared soln ls al) = do +declare (Undeclared soln ls al) = do ourName <- mgetOurName ourUInfo <- mgetUInfo ourName [pbdg,ebdg,hbdg] <- mapM (lift.lift . getUIBinding IMMeta) @@ -178,8 +180,8 @@ where insertMark = Map.insertWith $ \new old -> if overwrite then new else old askLockIndex :: UIMonad uiM => [Char] -> String -> (Int -> Bool) -> MaybeT (MainStateT uiM) Int -askLockIndex prompt failMessage pred = do - let ok = filter pred [0,1,2] +askLockIndex prompt failMessage p = do + let ok = filter p [0,1,2] case length ok of 0 -> (lift.lift) (drawError failMessage) >> mzero 1 -> return $ head ok @@ -194,13 +196,13 @@ confirmOrBail prompt = (guard =<<) $ lift.lift $ confirm prompt confirm :: UIMonad uiM => String -> uiM Bool confirm prompt = do - drawPrompt False $ prompt ++ " [y/N] " setYNButtons - waitConfirm <* endPrompt + confirm' where - waitConfirm = do - cmds <- getInput IMTextInput - maybe waitConfirm return (msum $ ansOfCmd <$> cmds) + confirm' = do + drawPrompt False $ prompt ++ " [y/N] " + cmds <- getSomeInput IMTextInput + maybe confirm' ((endPrompt >>) . pure) (msum $ ansOfCmd <$> cmds) ansOfCmd (CmdInputChar 'y') = Just True ansOfCmd (CmdInputChar 'Y') = Just True ansOfCmd (CmdInputChar c) = if isPrint c then Just False else Nothing @@ -211,21 +213,21 @@ -- | TODO: draw cursor textInput :: UIMonad uiM => String -> Int -> Bool -> Bool -> Maybe [String] -> Maybe String -> uiM (Maybe String) -textInput prompt maxlen hidden endOnMax mposss init = getText (fromMaybe "" init, Nothing) <* endPrompt +textInput prompt maxlen hidden endOnMax mposss base = getText (fromMaybe "" base, Nothing) <* endPrompt where getText :: UIMonad uiM => (String, Maybe String) -> uiM (Maybe String) - getText (s,mstem) = do - drawPrompt (length s == maxlen) $ prompt ++ " " ++ if hidden then replicate (length s) '*' else s - if endOnMax && isNothing mstem && maxlen <= length s - then return $ Just $ take maxlen s + getText (s0,mstem0) = do + drawPrompt (length s0 == maxlen) $ prompt ++ " " ++ if hidden then replicate (length s0) '*' else s0 + if endOnMax && isNothing mstem0 && maxlen <= length s0 + then return $ Just $ take maxlen s0 else do - cmds <- getInput IMTextInput - case foldM applyCmd (s,mstem) cmds of - Left False -> return Nothing - Left True -> return $ Just s - Right (s',mstem') -> getText (s',mstem') + cmds <- getSomeInput IMTextInput + case foldM applyCmd (s0,mstem0) cmds of + Left False -> return Nothing + Left True -> return $ Just s0 + Right (s,mstem) -> getText (s,mstem) where - applyCmd (s,mstem) (CmdInputChar c) = case c of + applyCmd (s,mstem) (CmdInputChar ch) = case ch of '\ESC' -> Left False '\a' -> Left False -- ^G '\ETX' -> Left False -- ^C @@ -251,8 +253,8 @@ | null later = head completions | otherwise = minimum later in Right (s',mstem) - _ -> Right $ if isPrint c - then ((if length s >= maxlen then id else (++[c])) s, Nothing) + _ -> Right $ if isPrint ch + then ((if length s >= maxlen then id else (++[ch])) s, Nothing) else (s,mstem) applyCmd x (CmdInputSelLock idx) = setTextOrSubmit x [lockIndexChar idx] @@ -265,3 +267,7 @@ applyCmd _ _ = Left False completes s s' = take (length s) s' == s setTextOrSubmit (s,_) t = if s == t then Left True else Right (t,Nothing) + +getSomeInput im = do + cmds <- getInput im + if null cmds then getSomeInput im else return cmds diff --git a/Intricacy.hs b/Intricacy.hs --- a/Intricacy.hs +++ b/Intricacy.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -9,16 +9,21 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. {-# LANGUAGE CPP #-} -#ifdef APPLE +#ifdef APPLE_SDL1 {-# LANGUAGE ForeignFunctionInterface #-} #endif module Main where -#ifdef MAIN_SDL +#ifdef MAIN_SDL1 import qualified SDLUI (UIM) import SDLUIMInstance () #endif +#ifdef MAIN_SDL2 +import qualified SDL2UI (UIM) +import SDL2UIMInstance () +#endif + #ifdef MAIN_CURSES import qualified CursesUI (UIM) import CursesUIMInstance () @@ -27,7 +32,7 @@ import Init import MainState -#ifdef APPLE +#ifdef APPLE_SDL1 foreign export ccall hs_MAIN :: IO () hs_MAIN :: IO () @@ -35,13 +40,23 @@ #endif main = main' -#ifdef MAIN_SDL +#ifdef MAIN_SDL1 (Just (doUI::SDLUI.UIM MainState -> IO (Maybe MainState))) #else +#ifdef MAIN_SDL2 + (Just (doUI::SDL2UI.UIM MainState -> IO (Maybe MainState))) +#else (Nothing :: (Maybe (CursesUI.UIM MainState -> IO (Maybe MainState)))) #endif +#endif #ifdef MAIN_CURSES (Just (doUI::CursesUI.UIM MainState -> IO (Maybe MainState))) #else +#ifdef MAIN_SDL1 (Nothing :: (Maybe (SDLUI.UIM MainState -> IO (Maybe MainState)))) +#else +#ifdef MAIN_SDL2 + (Nothing :: (Maybe (SDL2UI.UIM MainState -> IO (Maybe MainState)))) +#endif +#endif #endif diff --git a/KeyBindings.hs b/KeyBindings.hs --- a/KeyBindings.hs +++ b/KeyBindings.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -8,13 +8,14 @@ -- 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 CPP #-} + module KeyBindings (KeyBindings, bindings, findBindings, findBinding, showKey, showKeyChar, showKeyFriendly, showKeyFriendlyShort) where import Data.Bits (xor) import Data.Char import Data.List -import Data.Maybe import Command import GameStateTypes @@ -33,6 +34,31 @@ lowerToo = concatMap addLower where addLower b@(c, cmd) = [ b, (toLower c, cmd) ] +qwertyWASDish = + [ ('e', CmdDir WHSSelected hu) + , ('a', CmdDir WHSSelected $ neg hu) + , ('s', CmdDir WHSSelected hw) + , ('w', CmdDir WHSSelected $ neg hw) + , ('q', CmdDir WHSSelected hv) + , ('d', CmdDir WHSSelected $ neg hv) + , ('c', CmdRotate WHSSelected 1) + , ('z', CmdRotate WHSSelected $ -1) + ] + +keypadHex = + [ ('5', CmdWait) + , ('6', CmdDir WHSSelected hu) + , ('4', CmdDir WHSSelected $ neg hu) + , ('1', CmdDir WHSSelected hw) + , ('9', CmdDir WHSSelected $ neg hw) + , ('7', CmdDir WHSSelected hv) + , ('3', CmdDir WHSSelected $ neg hv) + , ('8', CmdRotate WHSSelected 1) + , ('2', CmdRotate WHSSelected $ -1) + ] + +selectedMovement = qwertyWASDish ++ keypadHex + qwertyViHex = [ ('l', CmdDir WHSHook hu) , ('h', CmdDir WHSHook $ neg hu) @@ -49,6 +75,8 @@ , ('k', CmdRotate WHSHook 1) , ('j', CmdRotate WHSHook $ -1) ] + +{- qwertyLeftHex = [ ('d', CmdDir WHSHook hu) , ('a', CmdDir WHSHook $ neg hu) @@ -75,49 +103,43 @@ , ('p', CmdDir WHSWrench hv) , ('k', CmdDir WHSWrench $ neg hv) ] - -keypadHex = - [ ('5', CmdWait) - , ('6', CmdDir WHSSelected hu) - , ('4', CmdDir WHSSelected $ neg hu) - , ('1', CmdDir WHSSelected hw) - , ('9', CmdDir WHSSelected $ neg hw) - , ('7', CmdDir WHSSelected hv) - , ('3', CmdDir WHSSelected $ neg hv) - , ('8', CmdRotate WHSSelected 1) - , ('2', CmdRotate WHSSelected $ -1) - ] +-} miscLockGlobal = lowerToo - [ ('X', CmdUndo) - , ('\b', CmdUndo) - , ('R', CmdRedo) + [ ('\b', CmdUndo) + , ('\r', CmdRedo) + , ('\n', CmdRedo) , (ctrl 'R', CmdRedo) - , (ctrl 'U', CmdUndo) - , ('^', CmdReset) + , (ctrl 'Y', CmdRedo) +#ifndef CURSES + , (ctrl 'Z', CmdUndo) +#endif + , ('R', CmdReset) , ('.', CmdWait) - , ('Z', CmdWait) , ('M', CmdMark) , ('\'', CmdJumpMark) + ] <> + [ ('X', CmdUndo) ] -miscGlobal = lowerToo - [ ('Q', CmdQuit) +miscGlobal = + [ ('\ESC', CmdQuit) + , ('Q', CmdQuit) + , (ctrl 'Q', CmdQuit) , (ctrl 'C', CmdQuit) , ('?', CmdHelp) , (ctrl 'B', CmdBind Nothing) , (ctrl 'L', CmdRedraw) +#ifdef CURSES , (ctrl 'Z', CmdSuspend) +#endif , ('%', CmdToggleColourMode) ] -lockGlobal = keypadHex ++ qwertyViHex ++ miscGlobal ++ miscLockGlobal - playOnly = lowerToo [ ('O', CmdOpen) , (' ', CmdWait) - , ('\r', CmdWait) - , ('\n', CmdWait) + , ('x', CmdToggle) , ('\t', CmdToggle) , ('*', CmdTile $ WrenchTile zero) , ('/', CmdTile HookTile) @@ -128,30 +150,27 @@ ] editMisc = lowerToo [ ('P', CmdPlay) - , (' ', CmdSelect) - , ('\r', CmdSelect) - , ('\n', CmdSelect) , ('T', CmdTest) - , ('W', CmdWriteState) + ] <> + [ ('W', CmdWriteState) , (ctrl 'S', CmdWriteState) + , (' ', CmdSelect) , ('=', CmdMerge) - , ('+', CmdMerge) - , ('&', CmdMerge) , ('0', CmdDelete) - , ('E', CmdDelete) ] tilesPaintRow = lowerToo - [ ('G', CmdTile BallTile) - , ('F', CmdTile $ ArmTile zero False) - , ('D', CmdTile $ PivotTile zero) - , ('S', CmdTile $ SpringTile Relaxed zero) - , ('A', CmdTile $ BlockTile []) - , ('Z', CmdDelete) + [ ('H', CmdTile BallTile) + , ('B', CmdTile $ ArmTile zero False) + , ('G', CmdTile $ PivotTile zero) + , ('V', CmdTile $ SpringTile Relaxed zero) + , ('F', CmdTile $ BlockTile []) + , ('x', CmdDelete) ] tilesAscii = [ ('o', CmdTile $ PivotTile zero) , ('O', CmdTile BallTile) , ('S', CmdTile $ SpringTile Relaxed zero) + , ('$', CmdTile $ SpringTile Relaxed zero) --, ('s', CmdTile $ SpringTile Stretched zero) --, ('$', CmdTile $ SpringTile Compressed zero) , ('-', CmdTile $ ArmTile zero False) @@ -164,11 +183,10 @@ ] editOnly = tilesPaintRow ++ editMisc ++ tilesAscii -playBindings = playOnly ++ lockGlobal -replayBindings = replayOnly ++ lockGlobal -editBindings = editOnly ++ lockGlobal -initBindings = lowerToo - [ ('S', CmdSolveInit Nothing) ] ++ miscGlobal +playBindings = playOnly ++ selectedMovement ++ qwertyViHex ++ miscGlobal ++ miscLockGlobal +replayBindings = replayOnly ++ miscGlobal ++ miscLockGlobal +editBindings = editOnly ++ selectedMovement ++ miscGlobal ++ miscLockGlobal +initBindings = lowerToo [ ('S', CmdSolveInit Nothing) ] ++ miscGlobal metaBindings = lowerToo [ ('C', CmdSelCodename Nothing) , ('H', CmdHome) @@ -176,9 +194,9 @@ , ('S', CmdSolve Nothing) , ('D', CmdDeclare Nothing) , ('V', CmdViewSolution Nothing) - , ('R', CmdRegister True) - , ('R', CmdRegister False) + , ('R', CmdRegister) , ('P', CmdPlaceLock Nothing) + , (ctrl 'R', CmdRetireLock) , ('E', CmdEdit) , ('L', CmdSelectLock) , ('O', CmdPrevLock) @@ -191,6 +209,7 @@ , ('^', CmdToggleCacheOnly) , ('>', CmdNextPage) , ('<', CmdPrevPage) + , (ctrl 'D', CmdDeleteLock) ] ++ miscGlobal impatienceBindings = lowerToo @@ -212,7 +231,8 @@ ++ [ ch | CmdInputChar ch <- [cmd] ] findBinding :: KeyBindings -> Command -> Maybe Char -findBinding = (listToMaybe.) . findBindings +findBinding _ (CmdInputChar ch) = Just ch +findBinding bdgs cmd = find (\ch -> lookup ch bdgs == Just cmd) $ findBindings bdgs cmd showKey :: Char -> String showKey ch @@ -221,17 +241,19 @@ | isPrint (unctrl ch) = '^':[unctrl ch] | otherwise = "[?]" -showKeyFriendly ' ' = "space" -showKeyFriendly '\r' = "return" -showKeyFriendly '\n' = "newline" -showKeyFriendly '\t' = "tab" -showKeyFriendly '\b' = "bksp" -showKeyFriendly ch = showKey ch +showKeyFriendly ' ' = "space" +showKeyFriendly '\r' = "return" +showKeyFriendly '\n' = "newline" +showKeyFriendly '\t' = "tab" +showKeyFriendly '\b' = "backspace" +showKeyFriendly '\ESC' = "escape" +showKeyFriendly ch = showKey ch -showKeyFriendlyShort '\r' = "ret" -showKeyFriendlyShort '\t' = "tab" -showKeyFriendlyShort '\b' = "bksp" -showKeyFriendlyShort ch = showKey ch +showKeyFriendlyShort '\r' = "ret" +showKeyFriendlyShort '\t' = "tab" +showKeyFriendlyShort '\b' = "bsp" +showKeyFriendlyShort '\ESC' = "esc" +showKeyFriendlyShort ch = showKey ch showKeyChar :: Char -> Char showKeyChar ch diff --git a/Lock.hs b/Lock.hs --- a/Lock.hs +++ b/Lock.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -36,10 +36,10 @@ nullpp = PlacedPiece (PHS zero) (Block []) reframe :: Lock -> Lock -reframe l@(f, st) = addTools $ delTools $ liftLock (setpp 0 (framePiece f)) l +reframe l@(f, _) = addTools $ delTools $ liftLock (setpp 0 (framePiece f)) l validLock :: Lock -> Bool -validLock lock@(f,st) = (st == stepPhysics st) && (lock == reframe lock) && validGameState st +validLock lock@(_, st) = (st == stepPhysics st) && (lock == reframe lock) && validGameState st type Solution = [PlayerMove] @@ -47,7 +47,7 @@ checkSolution lock pms = let (frame,st) = reframe lock tick :: GameState -> PlayerMove -> GameState - tick st pm = fst . runWriter $ physicsTick pm st + tick st' pm = fst . runWriter $ physicsTick pm st' in any (\st' -> checkSolved (frame,st')) $ scanl tick st pms checkSolved :: Lock -> Bool diff --git a/MainState.hs b/MainState.hs --- a/MainState.hs +++ b/MainState.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -15,20 +15,15 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.STM +import Control.Monad import Control.Monad.State import Control.Monad.Trans.Maybe import Control.Monad.Writer import Data.Array -import Data.Char -import Data.Function (on) -import Data.List import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.Time.Clock -import qualified Data.Vector as Vector -import Safe -import System.Directory import System.FilePath import AsciiLock @@ -54,12 +49,14 @@ endUI :: m () drawMainState :: MainStateT m () reportAlerts :: GameState -> [Alert] -> m () + onPhysicsTick :: m () clearMessage :: m () drawMessage :: String -> m () drawPrompt :: Bool -> String -> m () endPrompt :: m () drawError :: String -> m () showHelp :: InputMode -> HelpPage -> m Bool + getInputNoBlock :: InputMode -> m [ Command ] getInput :: InputMode -> m [ Command ] getChRaw :: m ( Maybe Char ) unblockInput :: m (IO ()) @@ -155,26 +152,24 @@ InitState {} -> IMInit MetaState {} -> IMMeta -newPlayState (frame,st) pms title tutLevel sub saved = PlayState st frame [] False False [] pms title tutLevel sub saved Map.empty +newPlayState (frame,st) pms title tutLev sub saved = PlayState st frame [] False False [] pms title tutLev sub saved Map.empty newReplayState st soln title = ReplayState st [] soln [] title Map.empty newEditState (frame,st) msoln mpath = EditState st [] [] frame mpath ((st,)<$>msoln) (Just (st, isJust msoln)) Nothing (PHS zero) (PHS zero) Map.empty -initInitState = do - (tut,initLocks) <- readInitProgress - return $ InitState tut initLocks +initInitState = uncurry InitState <$> readInitProgress initMetaState = do flag <- newTVarIO False errtvar <- newTVarIO Nothing invaltvar <- newTVarIO Nothing rnamestvar <- newTVarIO [] counttvar <- newTVarIO 0 - (initiated, saddr', auth, path) <- confFilePath "metagame.conf" >>= + (inited, saddr', auth, path) <- confFilePath "metagame.conf" >>= fmap (fromMaybe (False, defaultServerAddr, Nothing, "")) . readReadFile let saddr = updateDefaultSAddr saddr' let names = maybeToList $ authUser <$> auth (undecls,partials) <- readServerSolns saddr mlock <- fullLockPath path >>= readLock - return $ MetaState saddr undecls partials False auth names flag counttvar errtvar invaltvar rnamestvar Map.empty Map.empty Nothing path mlock 0 True initiated + return $ MetaState saddr undecls partials False auth names flag counttvar errtvar invaltvar rnamestvar Map.empty Map.empty Nothing path mlock 0 True inited type PartialSolutions = Map LockSpec SavedPlayState data SavedPlayState = SavedPlayState [PlayerMove] (Map Char [PlayerMove]) @@ -201,13 +196,13 @@ type InitLocks = Map HexVec InitLock accessibleInitLocks :: Bool -> InitLocks -> InitLocks -accessibleInitLocks tutSolved initLocks = - Map.filterWithKey (\v _ -> initLockAccessible v) initLocks +accessibleInitLocks isTutSolved locks = + Map.filterWithKey (\v _ -> initLockAccessible v) locks where initLockAccessible :: HexVec -> Bool initLockAccessible v = or - [ (v' == zero && tutSolved) || - (Just True == (initLockSolved <$> Map.lookup v' initLocks)) + [ (v' == zero && isTutSolved) || + (Just True == (initLockSolved <$> Map.lookup v' locks)) | v' <- (v +^) <$> hexDirs ] isLastInitLock :: InitLock -> Bool @@ -218,14 +213,14 @@ where getMoves = reverse . map snd . psGameStateMoveStack restorePlayState :: SavedPlayState -> Lock -> [PlayerMove] -> Maybe String -> Maybe Int -> Bool -> Bool -> MainState -restorePlayState (SavedPlayState pms markPMs) (frame,st) redoPms title tutLevel sub saved = +restorePlayState (SavedPlayState pms markPMs) (frame,st) redoPms title tutLev sub saved = (stateAfterMoves pms) { psMarks = Map.map stateAfterMoves markPMs } where - stateAfterMoves pms = let (stack,st') = applyMoves st pms - in (newPlayState (frame, st') redoPms title tutLevel sub saved) { psGameStateMoveStack = stack } - applyMoves st = foldl tick ([],st) + stateAfterMoves pms' = let (stack,st') = applyMoves st pms' + in (newPlayState (frame, st') redoPms title tutLev sub saved) { psGameStateMoveStack = stack } + applyMoves st' = foldl tick ([],st') tick :: ([(GameState,PlayerMove)],GameState) -> PlayerMove -> ([(GameState,PlayerMove)],GameState) - tick (stack,st) pm = ((st,pm):stack,fst . runWriter $ physicsTick pm st) + tick (stack,st') pm = ((st',pm):stack,fst . runWriter $ physicsTick pm st') readServerSolns :: ServerAddr -> IO ([Undeclared],PartialSolutions) readServerSolns saddr = if nullSaddr saddr then return ([],Map.empty) else do @@ -253,14 +248,14 @@ solved <- lift . (fromMaybe False <$>) . readReadFile $ initConfDir name ++ ".solved" partial <- lift . (fromMaybe Nothing <$>) . readReadFile $ initConfDir name ++ ".partial" return $ InitLock name desc lock solved partial - initLocks <- Map.mapMaybe id <$> mapM readInitLock namesMap - return (tut,initLocks) + (tut,) . Map.mapMaybe id <$> mapM readInitLock namesMap writeServerSolns :: ServerAddr -> MainState -> IO () writeServerSolns saddr MetaState { undeclareds=undecls, partialSolutions=partials } = unless (nullSaddr saddr) $ do confFilePath ("undeclared" ++ [pathSeparator] ++ saddrPath saddr) >>= flip writeReadFile undecls confFilePath ("partialSolutions" ++ [pathSeparator] ++ saddrPath saddr) >>= flip writeReadFile partials +writeServerSolns _ _ = error "writeServerSolns: tried to write non-meta state" readLock :: FilePath -> IO (Maybe (Lock, Maybe Solution)) readLock path = runMaybeT $ msum @@ -273,19 +268,19 @@ -- writeLock path lock = fullLockPath path >>= flip writeReadFile lock writeInitState :: MainState -> IO () -writeInitState InitState { tutProgress = tut, initLocks = initLocks } = do +writeInitState InitState { tutProgress = tut, initLocks = locks } = do initConfDir <- confFilePath "initiation" writeReadFile (initConfDir "tutProgress") tut let writeInitLockInfo :: InitLock -> IO () writeInitLockInfo (InitLock name _ _ solved partial) = do writeReadFile (initConfDir name ++ ".solved") solved writeReadFile (initConfDir name ++ ".partial") partial - mapM_ writeInitLockInfo initLocks + mapM_ writeInitLockInfo locks writeInitState _ = return () writeMetaState :: MainState -> IO () -writeMetaState ms@MetaState { curServer=saddr, curAuth=auth, curLockPath=path, initiated=initiated } = do - confFilePath "metagame.conf" >>= flip writeReadFile (initiated, saddr, auth, path) +writeMetaState ms@MetaState { curServer=saddr, curAuth=auth, curLockPath=path, initiated=inited } = do + confFilePath "metagame.conf" >>= flip writeReadFile (inited, saddr, auth, path) writeServerSolns saddr ms writeMetaState _ = return () @@ -297,7 +292,7 @@ unsaved <- editStateUnsaved isTested <- isJust <$> getCurTestSoln height <- gets $ aboveFrame . esFrame - return $ Just ("editing " ++ fromMaybe "[unnamed lock]" mpath ++ + return $ Just ("Editing " ++ fromMaybe "[unnamed lock]" mpath ++ (if isTested then " (Tested)" else "") ++ (if unsaved then " [+]" else " "), height @@ -476,8 +471,8 @@ tvar <- getRecordCachedFromCur False rec cOnly <- gets cacheOnly mfetched <- lift $ withImpatience $ atomically $ do - fetched@(FetchedRecord fresh _ _) <- readTVar tvar - check $ fresh || cOnly + fetched@(FetchedRecord isFresh _ _) <- readTVar tvar + check $ isFresh || cOnly return fetched case mfetched of Nothing -> lift (drawError "Request aborted") >> return Nothing @@ -490,15 +485,15 @@ withImpatience :: UIMonad uiM => IO a -> uiM (Maybe a) withImpatience m = do finishedTV <- liftIO $ newTVarIO Nothing - id <- liftIO $ forkIO $ m >>= atomically . writeTVar finishedTV . Just + tid <- liftIO $ forkIO $ m >>= atomically . writeTVar finishedTV . Just let waitImpatiently ticks = do finished <- liftIO $ readTVarIO finishedTV if isJust finished then return finished else do - abort <- impatience ticks - if abort - then liftIO $ killThread id >> return Nothing + cancel <- impatience ticks + if cancel + then liftIO $ killThread tid >> return Nothing else waitImpatiently $ ticks+1 waitImpatiently 0 @@ -512,10 +507,10 @@ ourUInfo <- mgetUInfo ourName -- Note that this is inverted when communicated in the interface: we show -- the number accessed rather than the number unaccessed. - let (pos,neg) = (countUnaccessedBy ourUInfo name, countUnaccessedBy uinfo ourName) - return (pos-neg,(pos,neg)) + let (posve,negve) = (countUnaccessedBy ourUInfo name, countUnaccessedBy uinfo ourName) + return (posve-negve,(posve,negve)) where - countUnaccessedBy ui name = length $ filter isNothing $ getAccessInfo ui name + countUnaccessedBy ui name' = length $ filter isNothing $ getAccessInfo ui name' accessedAL :: (UIMonad uiM) => ActiveLock -> MainStateT uiM Bool accessedAL (ActiveLock name idx) = (isJust <$>) $ runMaybeT $ do @@ -538,7 +533,7 @@ ServerMessage msg -> lift $ drawMessage $ "Server: " ++ msg ServerError err -> do lift $ drawMessage err - modify $ \ms -> ms {curAuth = Nothing} + -- modify $ \ms -> ms {curAuth = Nothing} _ -> return () initiationHelpText :: [String] @@ -571,7 +566,7 @@ , "The game judges players relative to each of their peers. There are no absolute rankings." , "You win a point of esteem against another player for one of their locks" , "if you have declared a solution to it, or if you have read three notes on it." - , "You also win a point for each empty lock slot if you can unlock all full slots." + , "You also win a point for each of their empty lock slots if you can unlock all full slots." , "Relative esteem is the points you win minus the points they win; +3 is best, -3 is worst." , "" , "If the secrets to one of your locks become widely disseminated, you may wish to replace it." @@ -598,8 +593,9 @@ , "As for those who unauthorisedly discover, and even try to profit from, said secrets..." , "you come to us." , "" - , "\"Our task, you see, is to produce the superficially secure locks necessary for this system:" - , "locks pickable with minimal tools, but with this fact obscured by their mechanical complexity." + , "\"Our task is to produce the apparently secure locks necessary for this system:" + , "locks which can in fact be picked with only minimal tools once you know the trick," + , "but with enough mechanical complexity to obscure this fact from the foolishly curious." , "" , "\"To push the designs to ever new extremes of intricacy, we run a ritual game." , "Today, we welcome you as its newest player." diff --git a/Maxlocksize.hs b/Maxlocksize.hs --- a/Maxlocksize.hs +++ b/Maxlocksize.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 diff --git a/Metagame.hs b/Metagame.hs --- a/Metagame.hs +++ b/Metagame.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -23,6 +23,7 @@ import GameStateTypes import Lock +notesNeeded, maxLocks :: Int notesNeeded = 3 maxLocks = 3 @@ -49,7 +50,7 @@ getAccessInfo :: UserInfo -> Codename -> [Maybe AccessedReason] getAccessInfo ui name = let mlinfos = elems $ userLocks ui - accessedSlot = maybe accessedAllExisting accessedLock + --accessedSlot = maybe accessedAllExisting accessedLock accessedAllExisting = all (maybe True accessedLock) mlinfos accessedLock linfo = public linfo || name `elem` accessedBy linfo in map (maybe @@ -132,6 +133,7 @@ 1 -> DelRead <$> get 2 -> PutLock <$> get <*> get 3 -> LockDelta <$> get <*> get + _ -> fail "bad tag to UserInfoDelta" instance Binary LockDelta where put (SetPubNote note) = put (0::Word8) >> put note @@ -149,6 +151,7 @@ 3 -> AddSolution <$> get 4 -> AddAccessed <$> get 5 -> return SetPublic + _ -> fail "bad tag to LockDelta" instance Binary LockInfo where put (LockInfo spec pk notes solved accessed) = put spec >> put pk >> put notes >> put solved >> put accessed diff --git a/Mundanities.hs b/Mundanities.hs --- a/Mundanities.hs +++ b/Mundanities.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -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 CPP #-} + module Mundanities where import Control.Applicative import Control.Arrow @@ -32,6 +34,9 @@ ignoreIOErrAlt :: (MonadIO m, MonadMask m, Alternative f) => m (f a) -> m (f a) ignoreIOErrAlt = handle ((\_ -> return empty) :: (Monad m, Alternative f) => IOError -> m (f a)) +nothingOnIOErr :: (MonadIO m, MonadMask m) => m a -> m (Maybe a) +nothingOnIOErr = ignoreIOErrAlt . (Just <$>) + warnIOErrAlt :: (MonadIO m, MonadMask m, Alternative f) => m (f a) -> m (f a) warnIOErrAlt = handle ((\e -> liftIO (print e) >> return empty) :: (MonadIO m, Alternative f) => IOError -> m (f a)) @@ -63,7 +68,11 @@ (const $ getAppUserDataDirectory "intricacy") getDataPath :: FilePath -> IO FilePath +#ifdef WINDOWS +getDataPath = pure +#else getDataPath = getDataFileName +#endif makeConfDir :: IO () makeConfDir = confFilePath "" >>= createDirectoryIfMissing False diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,5 +1,12 @@ This is an abbreviated summary; see the git log for gory details. +0.9: + Switch from SDL1 to SDL2. + Animate force conflicts. + Rework default keybindings and click-to-move. + Allow adjusting sound volume. + Add tutorial lock and 3 initiation locks. + Replace inefficient Read-based serialisation of user info with Binary. 0.8.2: Show esteem with symbols as well as colour (thanks Locria Cyber) Fix relative esteem calculation display diff --git a/Physics.hs b/Physics.hs --- a/Physics.hs +++ b/Physics.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -14,7 +14,7 @@ import Control.Monad.Writer import Data.Foldable (foldrM) import Data.List -import Data.Set (Set) +import Data.Monoid (Any (Any, getAny)) import qualified Data.Set as Set import Data.Vector (Vector, (!), (//)) import qualified Data.Vector as Vector @@ -108,13 +108,11 @@ stepPhysics = fst.runWriter.physicsTick NullPM type Source = Int -data SourcedForce = SForce Source Force Bool Bool - deriving (Eq, Ord, Show) resolveForces :: ForceChoices -> ForceChoices -> Dominance -> GameState -> Writer [Alert] GameState resolveForces plForces eForces eDominates st = let pln = Vector.length plForces dominates i j = case map (< pln) [i,j] of - [True,False] -> True + [True,False] -> True -- Note: never happens with current physics [False,False] -> eDominates (i-pln) (j-pln) _ -> False initGrps = (propagate st True <$> plForces) Vector.++ @@ -128,13 +126,13 @@ checkInconsistent i j fss = let st' = foldr applyForce st $ nub $ concat fss (inconsistencies,cols) = runWriter $ sequence - [ tell cols >> return [f,f'] + [ tell cols' >> return [f,f'] | [f,f'] <- sequence fss - , (True,cols) <- [ + , (True,cols') <- [ if forceIdx f == forceIdx f' then (f /= f',[]) - else let cols = collisions st' (forceIdx f) (forceIdx f') - in (not $ null cols, cols) ]] + else let cols' = collisions st' (forceIdx f) (forceIdx f') + in (not $ null cols', cols') ]] badConns = [ c | c <- connections st' , not $ springExtensionValid st' c ] in do @@ -167,12 +165,20 @@ , i <= j ] `execStateT` initGrps - let [blocked, unblocked] = map (nub.concatMap (fst.runWriter) . Vector.toList) $ - (\(x,y) -> [x,y]) $ Vector.partition (getAny.snd.runWriter) grps + let unresistedGrps = takeIfI (`elem` unresisted) grps + [blocked, unblocked] = map (nub.concatMap (fst.runWriter) . Vector.toList) $ + (\(x,y) -> [x,y]) $ Vector.partition (getAny.snd.runWriter) unresistedGrps + resistedGrps = takeIfI (`notElem` unresisted) grps + resisted = nub . concatMap (fst.runWriter) $ Vector.toList resistedGrps tell $ map AlertBlockedForce blocked + tell $ map AlertResistedForce resisted tell $ map AlertAppliedForce unblocked tell $ map AlertDivertedWrench $ divertedWrenches unblocked - return $ stopBlockedWrenches blocked unblocked $ foldr applyForce st unblocked + return $ stopBlockedWrenches (blocked <> resisted) unblocked $ foldr applyForce st unblocked + where + takeIfI :: (Int -> Bool) -> Vector a -> Vector a + takeIfI p as = (`Vector.imapMaybe` as) $ \i -> if p i then Just else const Nothing + resolveSinglePlForce :: Force -> GameState -> Writer [Alert] GameState resolveSinglePlForce force = resolveForces diff --git a/Protocol.hs b/Protocol.hs --- a/Protocol.hs +++ b/Protocol.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -42,6 +42,7 @@ | DeclareSolution Solution LockSpec ActiveLock LockIndex | SetLock Lock LockIndex Solution | GetRandomNames Int + | RetireLock ActiveLock | UndefinedAction deriving (Eq, Ord, Show, Read) @@ -99,6 +100,8 @@ put (GetRetired name) = put (11::Word8) >> put name put (SetEmail address) = put (12::Word8) >> put address put GetPublicKey = put (13::Word8) + put (RetireLock alock) = put (14::Word8) >> put alock + put UndefinedAction = error "Tried to put UndefinedAction" get = do tag <- get :: Get Word8 case tag of @@ -116,6 +119,7 @@ 11 -> GetRetired <$> get 12 -> SetEmail <$> get 13 -> return GetPublicKey + 14 -> RetireLock <$> get _ -> return UndefinedAction instance Binary Auth where @@ -137,6 +141,7 @@ put ServerFresh = put (11::Word8) put (ServedRetired lss) = put (12::Word8) >> put lss put (ServedPublicKey publicKey) = put (13::Word8) >> put (show publicKey) + put ServerUndefinedResponse = error "Tried to put ServerUndefinedResponse" get = do tag <- get :: Get Word8 case tag of diff --git a/README b/README --- a/README +++ b/README @@ -99,8 +99,8 @@ To _resolve_ these initial forces: * each initial force is 'propagated to a force group' - * if a group is 'inconsistent' with another group: if one of the group is - 'dominated' by the other, it is 'blocked'; else both are blocked + * if a group is 'inconsistent' with another group: if one of the groups is + 'dominated' by the other, it is 'blocked'; else both are blocked * each force in each unblocked force group is 'applied' To _apply_ a push: move the piece in the given direction. diff --git a/SDL2Glyph.hs b/SDL2Glyph.hs new file mode 100644 --- /dev/null +++ b/SDL2Glyph.hs @@ -0,0 +1,48 @@ +-- This file is part of Intricacy +-- Copyright (C) 2013-2025 Martin Bays +-- +-- 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 SDL2Glyph where + +import Command +import GameStateTypes +import Hex +import SDL.Primitive (Color) + +data ShowBlocks = ShowBlocksBlocking | ShowBlocksAll | ShowBlocksNone + deriving (Eq, Ord, Show, Read) + +data Glyph + = TileGlyph Tile Color + | SpringGlyph HexDir HexDir SpringExtension HexDir Color + | PivotGlyph TorqueDir HexDir Color + | ArmGlyph TorqueDir HexDir Color + | BlockedArm HexDir TorqueDir Color + | TurnedArm HexDir TorqueDir Color + | BlockedBlock Tile HexDir Color + | BlockedPush HexDir Color + | CollisionMarker + | HollowGlyph Color + | HollowInnerGlyph Color + | FilledHexGlyph Color + | ScoreGlyph (Maybe Int) + | ButtonGlyph Color + | UnboundButtonGlyph + | PathGlyph HexDir Color + | GateGlyph HexDir Color + | UseFiveColourButton Bool + | ShowBlocksButton ShowBlocks + | ShowButtonTextButton Bool + | VolumeButton Int + | WhsButtonsButton (Maybe WrHoSel) + | WhsEditButtonsButton (Maybe WrHoSel) + | FullscreenButton Bool + | DisplacedGlyph HexDir Glyph + | UnfreshGlyph + deriving (Eq, Ord, Show) diff --git a/SDL2Keys.hs b/SDL2Keys.hs new file mode 100644 --- /dev/null +++ b/SDL2Keys.hs @@ -0,0 +1,90 @@ +-- This file is part of Intricacy +-- Copyright (C) 2013-2025 Martin Bays +-- +-- 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 SDL2Keys (keysymChar) where + +import Data.Bits (xor) +import Data.Char (chr, ord, toUpper) +import SDL.Input.Keyboard + +import Util (fi) + +applyCtrl, applyMeta :: Char -> Char +applyCtrl ch | c <- fromEnum $ toUpper ch, fromEnum 'A' <= c, c <= fromEnum 'Z' = toEnum $ xor 64 c +applyCtrl ch = ch +applyMeta = toEnum . xor 128 . fromEnum + +keysymChar :: Keysym -> Char +keysymChar (Keysym _ k mods) = + let shift = keyModifierLeftShift mods || keyModifierRightShift mods + ctrl = keyModifierLeftCtrl mods || keyModifierRightCtrl mods + meta = keyModifierLeftAlt mods || keyModifierRightAlt mods + in (if meta then applyMeta else id) . + (if ctrl then applyCtrl . toUpper else id) $ + case k of + Keycode n | unwrapKeycode KeycodeA <= n && n <= unwrapKeycode KeycodeZ -> + chr (ord (if shift then 'A' else 'a') + fi (n - unwrapKeycode KeycodeA)) + Keycode n | unwrapKeycode KeycodeKP1 <= n && n <= unwrapKeycode KeycodeKP9 -> + chr (ord '1' + fi (n - unwrapKeycode KeycodeKP1)) + KeycodeReturn -> '\r' + KeycodeEscape -> '\ESC' + KeycodeBackspace -> '\b' + KeycodeTab -> '\t' + KeycodeSpace -> ' ' + KeycodeExclaim -> '!' + KeycodeQuoteDbl -> '"' + KeycodeHash -> '#' + KeycodePercent -> '%' + KeycodeDollar -> '$' + KeycodeAmpersand -> '&' + KeycodeQuote -> if shift then '"' else '\'' + KeycodeLeftParen -> '(' + KeycodeRightParen -> ')' + KeycodeAsterisk -> '*' + KeycodePlus -> '+' + KeycodeComma -> if shift then '<' else ',' + KeycodeMinus -> if shift then '_' else '-' + KeycodePeriod -> if shift then '>' else '.' + KeycodeSlash -> if shift then '?' else '/' + Keycode1 -> if shift then '!' else '1' + Keycode2 -> if shift then '@' else '2' + Keycode3 -> if shift then '#' else '3' + Keycode4 -> if shift then '$' else '4' + Keycode5 -> if shift then '%' else '5' + Keycode6 -> if shift then '^' else '6' + Keycode7 -> if shift then '&' else '7' + Keycode8 -> if shift then '*' else '8' + Keycode9 -> if shift then '(' else '9' + Keycode0 -> if shift then ')' else '0' + KeycodeColon -> ':' + KeycodeSemicolon -> if shift then ':' else ';' + KeycodeLess -> '<' + KeycodeEquals -> if shift then '+' else '=' + KeycodeGreater -> '>' + KeycodeQuestion -> '?' + KeycodeAt -> '@' + KeycodeLeftBracket -> if shift then '{' else '[' + KeycodeBackslash -> if shift then '|' else '\\' + KeycodeRightBracket -> if shift then '}' else ']' + KeycodeCaret -> '^' + KeycodeUnderscore -> '_' + KeycodeBackquote -> if shift then '~' else '`' + KeycodeRight -> '→' + KeycodeLeft -> '←' + KeycodeDown -> '↓' + KeycodeUp -> '↑' + KeycodeKPDivide -> if shift then '?' else '/' + KeycodeKPMultiply -> '*' + KeycodeKPMinus -> '-' + KeycodeKPPlus -> '+' + KeycodeKPEnter -> '\n' + KeycodeKP0 -> '0' + KeycodeKPPeriod -> '.' + _ -> '\0' diff --git a/SDL2Render.hs b/SDL2Render.hs new file mode 100644 --- /dev/null +++ b/SDL2Render.hs @@ -0,0 +1,345 @@ +-- This file is part of Intricacy +-- Copyright (C) 2013-2025 Martin Bays +-- +-- 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/. + +-- |SDL2Render: generic wrapper around sdl2-gfx for drawing on hex grids +module SDL2Render where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Data.Function (on) +import Data.List (maximumBy) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid +import Data.Semigroup as Sem +import Data.Vector.Storable (fromList) +import Data.Word (Word8) +import Foreign.C.Types (CInt) +import SDL hiding (perp, zero) +import qualified SDL.Font as TTF +import SDL.Primitive + +import Hex +import Util + +-- |SVec: screen vectors, in pixels +data SVec = SVec { cx, cy :: CInt } + deriving (Eq, Ord, Show) +instance Sem.Semigroup SVec where + (SVec x y) <> (SVec x' y') = SVec (x+x') (y+y') +instance Monoid SVec where + mempty = SVec 0 0 + mappend = (Sem.<>) +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 Sem.Semigroup FVec where + (FVec x y) <> (FVec x' y') = FVec (x+x') (y+y') +instance Monoid FVec where + mempty = FVec 0 0 + mappend = (Sem.<>) +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) + +ylen :: Float +ylen = 1 / sqrt 3 + +hexVec2SVec :: CInt -> HexVec -> SVec +hexVec2SVec size (HexVec x y z) = + SVec (fi (x-z) * size) (fi (-y) * 3 * ysize size) + +hexVec2FVec :: HexVec -> FVec +hexVec2FVec (HexVec x y z) = + FVec (fi $ x-z) (-fi y * 3 * ylen) + +fVec2SVec :: CInt -> FVec -> SVec +fVec2SVec size (FVec x y) = SVec + (round $ fi size * x) + (round $ fi size * y) + +sVec2dHV :: CInt -> SVec -> (Double,Double,Double) +sVec2dHV size (SVec sx sy) = + let sx',sy',size' :: Double + [sx',sy'] = map fi [sx,sy] + [size',ysize'] = map fi [size,ysize size] + y' = -sy' / ysize' / 3 + x' = ((sx' / size') - y') / 2 + z' = -((sx' / size') + y') / 2 + in (x',y',z') + +sVec2HexVec :: CInt -> SVec -> HexVec +sVec2HexVec size sv = + let (x',y',z') = sVec2dHV size sv + unrounded = Map.fromList [(1::Int,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 (\u -> u - sum (Map.elems rounded)) maxdiff rounded + in HexVec x y z + + +data RenderContext = RenderContext + { renderer :: Renderer + , renderBGTexture :: Maybe Texture + , renderHCentre :: HexPos + , renderSCentre :: SVec + , renderOffset :: FVec + , renderSize :: CInt + , renderFont :: Maybe TTF.Font + , renderWidth :: CInt + } +type RenderT = ReaderT RenderContext + +runRenderT = runReaderT + +applyOffset :: RenderContext -> RenderContext +applyOffset rc = rc + { renderSCentre = renderSCentre rc +^ fVec2SVec (renderSize rc) (renderOffset rc) + , renderOffset = zero + } + +displaceRender :: Monad m => FVec -> RenderT m a -> RenderT m a +displaceRender d = + local $ \rc -> rc { renderOffset = renderOffset rc +^ d } + +recentreAt :: Monad m => HexVec -> RenderT m a -> RenderT m a +recentreAt v = displaceRender (hexVec2FVec v) + +rescaleRender :: Monad m => Float -> RenderT m a -> RenderT m a +rescaleRender r = local $ (\rc -> rc + { renderSize = round $ r * fi (renderSize rc) } ) . applyOffset + +withFont :: Monad m => Maybe TTF.Font -> RenderT m a -> RenderT m a +withFont font = local $ \rc -> rc { renderFont = font } + +renderPos :: Monad m => Integral i => FVec -> RenderT m (V2 i) +renderPos v = do + size <- asks renderSize + c <- asks renderSCentre + off <- asks renderOffset + let SVec x y = c +^ fVec2SVec size (v +^ off) + return $ V2 (fi x) (fi y) +renderLen :: Monad m => Integral i => Float -> RenderT m i +renderLen l = do + size <- asks renderSize + return $ round $ l * fi size + + +-- wrappers around sdl-gfx functions +pixelR v col = do + p <- renderPos v + rend <- asks renderer + void.liftIO $ pixel rend p col + +aaLineR v v' col = do + p <- renderPos v + p' <- renderPos v' + rend <- asks renderer + void.liftIO $ smoothLine rend p p' col + +polygonR :: MonadIO m => Bool -> [FVec] -> Color -> RenderT m () +polygonR fill verts col = do + ps <- mapM renderPos verts + rend <- asks renderer + let (xs,ys) = unzip [(x,y) | V2 x y <- ps] + void.liftIO $ (if fill then fillPolygon else smoothPolygon) rend (fromList xs) (fromList ys) col + +arcR v rad a1 a2 col = do + p <- renderPos v + r <- renderLen rad + rend <- asks renderer + void.liftIO $ arc rend p r a1 a2 col + +filledCircleR v rad col = do + p <- renderPos v + r <- renderLen rad + rend <- asks renderer + void.liftIO $ fillCircle rend p r col + +aaCircleR v rad col = do + p <- renderPos v + r <- renderLen rad + rend <- asks renderer + void.liftIO $ smoothCircle rend p 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 + polygonR True verts fillCol + polygonR False verts $ opaquify rimCol + +filledPolygonR :: MonadIO m => [FVec] -> Color -> RenderT m () +filledPolygonR = polygonR True + +rimmedCircleR v rad fillCol rimCol = void $ do + filledCircleR v rad fillCol + aaCircleR v rad $ opaquify rimCol + +thickLineR :: (Functor m, MonadIO m) => FVec -> FVec -> Float -> Color -> RenderT m () +thickLineR from to thickness col = + let FVec dx dy = to -^ from + baseThickness = (1/16) + s = baseThickness * thickness / sqrt (dx*dx + dy*dy) + perp = (s/2) **^ FVec dy (-dx) + in rimmedPolygonR + [ from +^ perp, to +^ perp + , to +^ neg perp, from +^ neg perp] + 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 = thickLinesR (verts ++ take 1 verts) + + +ysize :: CInt -> CInt +ysize = fi . (map (\size -> round $ fi size * ylen :: Int) [0::Int ..] !!) . fi + +corner :: Int -> FVec +corner hextnt = FVec x y + where + [x,y] = f hextnt + 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) + +outerCorners :: [FVec] +outerCorners = map corner [0..5] + +innerCorner :: HexDir -> FVec +innerCorner dir = FVec x y + where + [x,y] = f dir + f d | d == hu = [2/3, 0] + | d == hv = [-1/3, -ylen] + | d == hw = [-1/3, ylen] + | d == zero = [0,0] + | not (isHexDir d) = error "innerCorner: not a hexdir" + | otherwise = map (\z -> -z) $ f $ neg d + +innerCorners :: [FVec] +innerCorners = map innerCorner hexDirs + +edge :: HexDir -> FVec +edge dir = FVec x y + where + [x,y] = f dir + f d | d == hu = [1, 0] + | d == hv = [-1/2, -3*ylen/2] + | d == hw = [-1/2, 3*ylen/2] + | not (isHexDir d) = error "edge: not a hexdir" + | otherwise = map (\z -> -z) $ f $ neg d + +rotFVec :: Float -> FVec -> FVec -> FVec +rotFVec th (FVec bx by) v@(FVec x y) + | th == 0 = v + | otherwise = FVec (bx + c*dx-s*dy) (by + s*dx+c*dy) + where + dx = x-bx + dy = y-by + c = cos th + s = sin th + +black, white, orange :: Color +-- FIXME: why not actually black? +black = V4 0x01 0 0 0 +white = V4 0xff 0xff 0xff 0 +orange = V4 0xff 0x7f 0 0 + +colourWheel :: Int -> Color +colourWheel n = V4 r g b a + where [r,g,b] = map (\ok -> if ok then 0xff else 0) $ colourWheel' n + a = 0x00 + colourWheel' 0 = [True, False, False] + colourWheel' 1 = [True, True, False] + colourWheel' n' = let [r',g',b'] = colourWheel' $ n'-2 in [b',r',g'] + +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 -> Color +colourOf colouring idx = + maybe white colourWheel (Map.lookup idx colouring) + +setColorAlpha :: Word8 -> Color -> Color +setColorAlpha a (V4 r g b _) = V4 r g b a +bright = setColorAlpha 0xff +brightish = setColorAlpha 0xc0 +dim = setColorAlpha 0xa0 +obscure = setColorAlpha 0x80 +faint = setColorAlpha 0x40 +invisible = setColorAlpha 0x00 + +opaquify (V4 r g b a) = + let scale :: Int -> Int + scale v = (v * fi a) `div` 0xff + [r',g',b'] = fi . scale . fi <$> [r,g,b] + in V4 r' g' b' 0xff + +messageCol, dimWhiteCol, buttonTextCol, errorCol :: Color +messageCol = white +dimWhiteCol = V4 0xa0 0xa0 0xa0 0 +buttonTextCol = white +errorCol = red + +erase :: (Functor m, MonadIO m) => RenderT m () +erase = fillRectBG Nothing + +fillRectBG :: (Functor m, MonadIO m) => Maybe (Rectangle CInt) -> RenderT m () +fillRectBG mrect = do + rend <- asks renderer + mbgt <- asks renderBGTexture + void $ liftIO $ maybe + ((rendererDrawColor rend $= black) >> fillRect rend mrect) + (\bgt -> copy rend bgt mrect mrect) + mbgt + +blankRow v = do + (scrCentre, off, size, w) <- asks $ liftM4 (,,,) renderSCentre renderOffset renderSize renderWidth + let SVec _ y = scrCentre +^ fVec2SVec size (off +^ hexVec2FVec v) + h = ceiling (fi (size * 3 `div` 2) * 2 / sqrt 3 :: Float) + fillRectBG $ Just $ Rectangle (P $ V2 0 (fi $ y-h`div`2)) (V2 (fi w) (fi h)) + +blitAt :: (Functor m, MonadIO m) => Texture -> HexVec -> RenderT m () +blitAt texture v = do + (scrCentre, off, size) <- asks $ liftM3 (,,) renderSCentre renderOffset renderSize + blitAtSVec texture $ scrCentre +^ fVec2SVec size (off +^ hexVec2FVec v) +blitAtSVec :: (Functor m, MonadIO m) => Texture -> SVec -> RenderT m () +blitAtSVec texture (SVec x y) = do + rend <- asks renderer + TextureInfo _ _ w h <- queryTexture texture + liftIO . copy rend texture Nothing . Just $ + Rectangle (P $ V2 (fi x - w`div`2) (fi y - h`div`2)) (V2 w h) diff --git a/SDL2RenderCache.hs b/SDL2RenderCache.hs new file mode 100644 --- /dev/null +++ b/SDL2RenderCache.hs @@ -0,0 +1,426 @@ +-- This file is part of Intricacy +-- Copyright (C) 2013-2025 Martin Bays +-- +-- 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/. + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module SDL2RenderCache where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import Data.Function (on) +import qualified Data.Text as T +import Foreign.C.Types (CInt) +import SDL hiding (get, rotate, zero) +import qualified SDL.Font as TTF +import SDL.Primitive (Color) + +import BoardColouring +import Command +import GameState +import GameStateTypes +import Hex +import SDL2Glyph +import SDL2Render +import Util + +import qualified SimpleCache as SC + +type SizedGlyph = (Glyph,CInt) +type CachedGlyphs = SC.SimpleCache SizedGlyph Texture +maxCachedGlyphs = 400 +emptyCachedGlyphs = SC.empty maxCachedGlyphs destroyTexture + +type CachedText = SC.SimpleCache (T.Text, TTF.Font) (Texture, V2 CInt) +maxCachedText = 100 +emptyCachedText = SC.empty maxCachedText (destroyTexture . fst) + +instance Ord TTF.Font where compare = compare `on` TTF.unwrap + +data RenderCache = RenderCache + { cachedGlyphs :: CachedGlyphs + , cachedText :: CachedText + } +emptyRenderCache = RenderCache emptyCachedGlyphs emptyCachedText + +deallocRenderCache :: RenderCache -> IO () +deallocRenderCache (RenderCache glyphs text) = SC.deallocAll glyphs >> SC.deallocAll text + +modGlyphs :: (CachedGlyphs -> CachedGlyphs) -> RenderCache -> RenderCache +modGlyphs f c = c { cachedGlyphs = f $ cachedGlyphs c } + +modText :: (CachedText -> CachedText) -> RenderCache -> RenderCache +modText f c = c { cachedText = f $ cachedText c } + +type RenderM = RenderT (StateT RenderCache IO) +-- |XXX: caller must call deallocRenderCache on returned cache before destroying +-- the renderer! +runRenderM :: RenderM a -> RenderCache -> RenderContext -> IO (a,RenderCache) +runRenderM m cache rc = runStateT (runReaderT m rc) cache + +getOrInsert :: (Eq k, Ord k) => (RenderCache -> SC.SimpleCache k v) + -> (SC.SimpleCache k v -> (RenderCache -> RenderCache)) + -> k -> RenderM v -> RenderM v +getOrInsert proj setter k m = do + cache <- lift $ gets proj + v <- maybe m pure $ cache SC.!? k + cache' <- liftIO $ SC.insert k v cache + lift . modify $ setter cache' + pure v + +drawAt :: Glyph -> HexPos -> RenderM () +drawAt gl pos = do + centre <- asks renderHCentre + drawAtRel gl (pos -^ centre) + +drawAtRel :: Glyph -> HexVec -> RenderM () +drawAtRel gl v = recentreAt v $ renderGlyphCaching gl + +renderGlyphCaching :: Glyph -> RenderM () +renderGlyphCaching gl = do + size <- asks renderSize + let sgl = (gl,size) + -- |larger than you might expect, to handle DisplacedGlyph + w = size*4 + 1 + h = ysize size*8 + 1 + newGlyphSurf = do + csurf <- createRGBSurface (V2 w h) RGB888 + surfaceColorKey csurf $= Just (V4 0 0 0 0) + return csurf + renderOnCache csurf = do + crend <- liftIO $ createSoftwareRenderer csurf + let ccxt rc = rc { renderer = crend, renderSCentre = SVec (w`div`2) (h`div`2), renderOffset = zero } + local ccxt $ renderGlyph gl + liftIO $ destroyRenderer crend + rend <- asks renderer + texture <- createTextureFromSurface rend csurf + textureBlendMode texture $= BlendAlphaBlend + pure texture + blitGlyph texture = do + V2 x y <- renderPos zero + blitAtSVec texture $ SVec x y + if cacheable gl + then blitGlyph <=< getOrInsert cachedGlyphs (modGlyphs . const) sgl $ do + csurf <- newGlyphSurf + texture <- renderOnCache csurf + freeSurface csurf + pure texture + else renderGlyph gl + where + -- Blocktiles need careful FVec calculations to join up right + cacheable (TileGlyph (BlockTile adjs) _) | not (null adjs) = False + cacheable (HollowGlyph _) = False + cacheable (FilledHexGlyph _) = False + cacheable _ = True + +renderGlyph :: Glyph -> RenderM () +renderGlyph (TileGlyph (BlockTile adjs) col) = + rimmedPolygonR corners col $ bright col + where + corners = concat [ + if any adjAt [0,1] + then [corner $ hextant dir] + else [innerCorner dir | not (adjAt $ -1)] + | dir <- hexDirs + , let adjAt r = rotate r dir `elem` adjs + ] + +renderGlyph (TileGlyph (SpringTile extn dir) col) = + renderGlyph $ SpringGlyph zero zero extn dir col + +renderGlyph (TileGlyph (PivotTile dir) col) = do + renderGlyph $ PivotGlyph 0 dir col + +renderGlyph (TileGlyph (ArmTile dir _) col) = + renderGlyph $ ArmGlyph 0 dir col + +renderGlyph (TileGlyph HookTile col) = + rimmedCircleR zero (7/8) col $ bright col + +renderGlyph (TileGlyph (WrenchTile mom) col) = do + rimmedCircleR zero (1/3) col $ bright col + when (mom /= zero) $ + let + from = innerCorner $ neg mom + to = edge $ neg mom + shifts = [(1 / 2) **^ (b -^ a) | + let a = innerCorner $ neg mom, + rot <- [- 1, 0, 1], + let b = innerCorner $ rotate rot $ neg mom] + in sequence_ + [ aaLineR (from+^shift) (to+^shift) col + | shift <- shifts ] + +renderGlyph (TileGlyph BallTile col) = + rimmedCircleR zero (7/8) (faint col) (obscure col) + +renderGlyph (SpringGlyph rootDisp endDisp extn dir col) = + thickLinesR points 1 $ brightness col + where + n :: Int + n = 3*case extn of + Stretched -> 1 + Relaxed -> 2 + Compressed -> 4 + brightness = dim + dir' = if dir == zero then hu else dir + s = corner (hextant dir' - 1) +^ innerCorner endDisp + off = corner (hextant dir') +^ innerCorner endDisp + e = corner (hextant dir' - 3) +^ innerCorner rootDisp + points = [ b +^ (fi i / fi n) **^ (e -^ s) + | i <- [0..n] + , i`mod`3 /= 1 + , let b = if i`mod`3==0 then s else off ] + +renderGlyph (PivotGlyph rot dir col) = do + rimmedCircleR zero (7/8) col $ bright col + when (dir /= zero) + $ aaLineR from to $ bright col + where + from = rotFVec th c $ (7/8) **^ edge (neg dir) + to = rotFVec th c $ (7/8) **^ edge dir + c = FVec 0 0 + th = - fi rot * pi / 12 + +renderGlyph (ArmGlyph rot dir col) = + thickLineR from to 1 $ bright col + where + dir' = if dir == zero then hu else dir + from = rotFVec th c $ edge $ neg dir' + to = rotFVec th c $ innerCorner dir' + c = 2 **^ edge (neg dir') + th = - fi rot * pi / 12 + +renderGlyph (BlockedArm armdir tdir col) = + thickLineR from to (1/3) 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 (head arms) 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 + filledPolygonR [FVec (-l) 0, FVec 0 l, FVec l 0, FVec 0 (-l)] (obscure purple) + renderStrColAt (bright orange) "!" zero + where l = 2/3 + +renderGlyph (HollowGlyph col) = + polygonR False outerCorners $ opaquify col +renderGlyph (HollowInnerGlyph col) = + polygonR False innerCorners $ opaquify col + +renderGlyph (FilledHexGlyph col) = + rimmedPolygonR outerCorners col $ brightish col + +renderGlyph (ScoreGlyph relScore) = + sequence_ $ [ aaLineR from to $ bright white | (from,to) <- case relScore of + Just 1 -> plus 0 + Just 2 -> plus (-1) <> plus 1 + Just 3 -> plus (-2) <> plus 0 <> plus 2 + Just (-1) -> [horiz 0] + Just (-2) -> [horiz $ -1, horiz 1] + Just (-3) -> [horiz $ -2, horiz 0, horiz 2] + _ -> [] + ] + where + vert n = let x = n/5 in (FVec x $ -(4/3)*ylen, FVec x $ -ylen) + horiz n = let y = -(7/6)*ylen in (FVec (n/5 - 1/9) y, FVec (n/5 + 1/9) y) + plus n = [vert n, horiz n] + + +renderGlyph (ButtonGlyph col) = + renderGlyph (TileGlyph (BlockTile []) col) + +renderGlyph UnboundButtonGlyph = + filledCircleR zero (1/3) $ bright black + +renderGlyph (PathGlyph dir col) = do + aaLineR from to col + where + from = edge $ neg dir + to = edge dir + +renderGlyph (GateGlyph dir col) = do + thickLineR from to 1 col + where + from = corner $ 1 + hextant dir + to = corner $ 4 + hextant dir + +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 (VolumeButton vol) = do + sequence_ [ arcR (FVec (-2/3) 0) r (-20) 20 + (if vol > 0 then bright green else dim red) + | r <- [1/3] <> [2/3 | vol > 16 || vol == 0] <> [1 | vol > 32 || vol == 0 ] ] + unless (vol > 0) $ + aaLineR (innerCorner hw) (innerCorner $ neg hw) $ dim red + +renderGlyph (WhsButtonsButton Nothing) = rescaleRender (1/3) $ do + renderGlyph (ButtonGlyph (dim red)) + sequence_ [ displaceRender ((5/3) **^ edge dir) $ + renderGlyph (ButtonGlyph (dim purple)) + | dir <- hexDirs ] +renderGlyph (WhsButtonsButton (Just whs)) = rescaleRender (1/3) $ 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 (WhsEditButtonsButton Nothing) = + renderGlyph $ WhsButtonsButton Nothing +renderGlyph (WhsEditButtonsButton (Just _)) = + rescaleRender (1/3) $ renderGlyph cursorGlyph + +renderGlyph (FullscreenButton fs) = do + thickPolygonR corners 1 $ activeCol (not fs) + thickPolygonR corners' 1 $ activeCol fs + where + activeCol True = opaquify $ dim green + activeCol False = opaquify $ dim red + corners = [ (2/3) **^ (if dir `elem` [hu,neg hu] then edge else innerCorner) dir + | dir <- hexDirs ] + corners' = map (((2/3)**^) . corner) [0..5] + +renderGlyph (DisplacedGlyph dir glyph) = + displaceRender (innerCorner dir) $ renderGlyph glyph + +renderGlyph UnfreshGlyph = do + let col = bright red + renderGlyph (HollowInnerGlyph col) + sequence_ [pixelR (FVec (i/4) 0) col + | i <- [-1..1] ] + +playerGlyph = FilledHexGlyph + +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 x y z) = let + [r,g,b] = map (\h -> fi $ 0xff * (5 + abs h)`div`maxR) [x,y,z] + a = fi $ (0x70 * (maxR - abs (hexLen v)))`div`maxR + in V4 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]) + PlacedPiece pos' _ -> (pos',[]) + col = if blocking then bright purple else dim $ colourOf colouring idx + sequence_ [ drawAt (BlockedArm arm dir col) (arm +^ pos) | + arm <- arms ] +drawBlocked st _ blocking (Push idx dir) = do + let footprint = plPieceFootprint $ getpp st idx + col = bright $ if blocking then purple else orange + sequence_ [ drawAt (BlockedPush dir col) pos + | pos <- footprint + , (dir+^pos) `notElem` footprint ] + -- 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]) + PlacedPiece pos' _ -> (pos',[]) + col = dim $ colourOf colouring idx + sequence_ [ drawAt (TurnedArm arm dir col) (arm +^ pos) | + arm <- arms ] +drawApplied _ _ _ = return () + + +data Alignment = Centred | LeftAligned | ScreenCentred +renderStrColAt,renderStrColAtLeft,renderStrColAtCentre :: Color -> String -> HexVec -> RenderM () +renderStrColAt = renderStrColAt' Centred +renderStrColAtLeft = renderStrColAt' LeftAligned +renderStrColAtCentre = renderStrColAt' ScreenCentred +renderStrColAt' :: Alignment -> Color -> String -> HexVec -> RenderM () +renderStrColAt' _ _ "" _ = pure () +renderStrColAt' align c str v = let txt = T.pack str in void . runMaybeT $ do + font <- MaybeT $ asks renderFont + rend <- lift $ asks renderer + (texture,dims@(V2 w h)) <- lift . getOrInsert cachedText (modText . const) (txt,font) $ do + fsurf <- liftIO $ TTF.blended font c $ T.pack str + dims' <- surfaceDimensions fsurf + texture <- createTextureFromSurface rend fsurf + freeSurface fsurf + pure (texture, dims') + (scrCentre, off, size) <- lift $ asks $ liftM3 (,,) renderSCentre renderOffset renderSize + let SVec x y = scrCentre +^ fVec2SVec size (off +^ hexVec2FVec v) + +^ neg (SVec 0 (h`div`2) +^ + case align of + Centred -> SVec (w`div`2) 0 + _ -> SVec 0 0) + x' = case align of + ScreenCentred -> cx scrCentre - (w `div` 2) + _ -> x + liftIO $ copy rend texture Nothing (Just $ Rectangle (P $ V2 (fi x') (fi y)) dims) + +renderStrColAbove,renderStrColBelow :: Color -> String -> HexVec -> RenderM () +renderStrColAbove = renderStrColVShifted True +renderStrColBelow = renderStrColVShifted False +renderStrColVShifted :: Bool -> Color -> String -> HexVec -> RenderM () +renderStrColVShifted up c str v = + displaceRender (FVec 1 0) $ renderStrColAt c str $ v +^ (if up then hv else hw) diff --git a/SDL2UI.hs b/SDL2UI.hs new file mode 100644 --- /dev/null +++ b/SDL2UI.hs @@ -0,0 +1,1003 @@ +-- This file is part of Intricacy +-- Copyright (C) 2013-2025 Martin Bays +-- +-- 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/. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module SDL2UI where + +import Control.Applicative +import Control.Monad +import Control.Monad.Catch (handleAll) +import Control.Monad.State +import Control.Monad.Trans.Maybe +import Data.List +import Data.Map (Map, (!?)) +import qualified Data.Map as Map +import Data.Maybe +import Data.Ratio +import Data.Time.Clock (getCurrentTime) +import Data.Word +import qualified SDL +import SDL hiding (get, rotate, zero, (*^)) +import qualified SDL.Font as TTF +import SDL.Primitive (Color) +import System.FilePath +--import Debug.Trace (traceShow) +import Foreign.C.Types (CInt) +import Foreign.Ptr (nullPtr) + +#ifdef SOUND +import SDL.Mixer +import System.Random (randomRIO) +#endif + +import qualified SimpleCache as SC + +import BoardColouring +import Command +import Font +import GameState +import GameStateTypes +import Hex +import InputMode +import KeyBindings +import Lock +import Maxlocksize +import Metagame +import Mundanities +import Physics +import SDL2Glyph +import SDL2Render +import SDL2RenderCache +import Util + +data UIState = UIState + { scrDimen :: V2 CInt + , sdlWindow :: Maybe Window + , vidRenderer :: Maybe Renderer + , backbuffer :: Maybe Texture + , unblockEventType :: Maybe (RegisteredEventType ()) + , bgTexture :: Maybe Texture + , rCache :: RenderCache + , lastDrawArgs :: Maybe DrawArgs + , miniLocks :: SC.SimpleCache Lock Texture + , registeredSelectables :: Map HexVec Selectable + , contextButtons :: [ButtonGroup] + , uiOptions :: UIOptions + , settingBinding :: Maybe Command + , uiKeyBindings :: Map InputMode KeyBindings + , dispFont :: Maybe TTF.Font + , dispFontSmall :: Maybe TTF.Font + , lastFrameTicks :: Word32 + , paintTileIndex :: Int + , leftButtonDown :: Maybe HexVec + , middleButtonDown :: Maybe HexVec + , rightButtonDown :: Maybe HexVec + , mousePos :: (HexVec,Bool) + , message :: Maybe (Color, String) + , hoverStr :: Maybe String + , dispCentre :: HexPos + , dispLastCol :: PieceColouring + , animFrame :: Int + , nextAnimFrameAt :: Maybe Word32 + , fps :: Int +#ifdef SOUND + , sounds :: Map String [Chunk] +#endif + } + +emptyMiniLocks :: SC.SimpleCache Lock Texture +emptyMiniLocks = SC.empty 50 destroyTexture + +type UIM = StateT UIState IO +nullUIState = UIState (V2 0 0) Nothing Nothing Nothing Nothing Nothing emptyRenderCache Nothing emptyMiniLocks Map.empty [] + defaultUIOptions Nothing Map.empty Nothing Nothing 0 0 Nothing Nothing Nothing + (zero,False) Nothing Nothing (PHS zero) Map.empty 0 Nothing 50 +#ifdef SOUND + Map.empty +#endif + +data UIOptions = UIOptions + { useFiveColouring :: Bool + , showBlocks :: ShowBlocks + , jiggleBlocked :: Bool + , whsButtons :: Map InputMode WrHoSel + , useBackground :: Bool + , fullscreen :: Bool + , showButtonText :: Bool + , soundVolume :: Int + , uiAnimTime :: Word32 + , shortUiAnimTime :: Word32 + } + deriving (Eq, Ord, Show, Read) +defaultUIOptions = UIOptions False ShowBlocksNone True Map.empty True False True 64 50 20 + +modifyUIOptions :: (UIOptions -> UIOptions) -> UIM () +modifyUIOptions f = modify $ \s -> s { uiOptions = f $ uiOptions s } + +renderToMain :: RenderM a -> UIM a +renderToMain m = do + Just rend <- gets vidRenderer + cache <- gets rCache + (a,cache') <- renderToMainWithRenderer rend cache m + modify $ \s -> s { rCache = cache' } + pure a +renderToMainWithRenderer :: Renderer -> RenderCache -> RenderM a -> UIM (a, RenderCache) +renderToMainWithRenderer rend cache m = do + (scrCentre, size) <- getGeom + centre <- gets dispCentre + mfont <- gets dispFont + bgt <- gets bgTexture + V2 w _ <- gets scrDimen + liftIO $ runRenderM m cache $ RenderContext rend bgt centre scrCentre zero size mfont w + +refresh :: UIM () +refresh = do + -- We use our own backbuffer, so we can update parts of the screen between + -- presentations without the rest of the screen being invalidated. + Just rend <- gets vidRenderer + Just bb <- gets backbuffer + rendererRenderTarget rend $= Nothing + copy rend bb Nothing Nothing + present rend + clear rend + rendererRenderTarget rend $= Just bb + +clearFrame :: UIM () +clearFrame = do + Just rend <- gets vidRenderer + rendererDrawColor rend $= black + SDL.clear rend + +waitFrame :: UIM () +waitFrame = do + next <- gets $ (+ 1000 `div` 30) . lastFrameTicks + now <- ticks + when (now < next) $ + liftIO $ delay (next - now) + now' <- ticks + modify $ \ds -> ds { lastFrameTicks = now' } + + +data Button = Button { buttonPos :: HexVec, buttonCmd :: Command, buttonHelp :: [ButtonHelp] } + deriving (Eq, Ord, Show) +type ButtonGroup = ([Button],(Int,Int)) +type ButtonHelp = (String, HexVec) +singleButton :: HexVec -> Command -> Int -> [ButtonHelp] -> ButtonGroup +singleButton pos cmd col helps = ([Button pos cmd helps], (col,0)) +getButtons :: InputMode -> UIM [ ButtonGroup ] +getButtons mode = do + mwhs <- gets $ (!? mode) . whsButtons . uiOptions + cntxtButtons <- gets contextButtons + return $ cntxtButtons ++ global ++ case mode of + IMEdit -> [ + singleButton (tl+^hv+^neg hw) CmdTest 1 [("test", hu+^neg hw)] + , singleButton (tl+^neg hw) CmdPlay 2 [("play", hu+^neg hw)] + , markButtonGroup + , singleButton (br+^2*^hu) CmdWriteState 2 [("save", hu+^neg hw)] ] + ++ whsBGs mwhs + ++ [ ([Button (paintButtonStart +^ hu +^ i*^hv) (paintTileCmds!!i) [] + | i <- take (length paintTiles) [0..] ],(5,0)) ] + IMPlay -> whsBGs mwhs + IMReplay -> [ markButtonGroup ] + IMMeta -> + [ 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) CmdInitiation 3 [("initi",hu+^neg hw),("ation",hu+^neg hv)] + ] + + _ -> [] + where + global = if mode `elem` [IMTextInput,IMImpatience] then [] else + [ singleButton br CmdQuit 0 [("quit",hu+^neg hw)] + , singleButton (tr +^ 3*^hv +^ 3*^hu) CmdHelp 3 [("help",hu+^neg hw)] ] + whsBGs :: Maybe WrHoSel -> [ ButtonGroup ] + whsBGs Nothing = [] + whsBGs (Just whs) = + let edit = mode == IMEdit + in [ ( [ Button bl (if edit then CmdSelect else CmdWait) [] ], (0,0)) + , ( [ Button (bl+^dir) (CmdDir whs dir) + (if dir==hu then [("move",hu+^neg hw),(if edit then "piece" else whsStr whs,hu+^neg hv)] else []) + | dir <- hexDirs ], (5,0) ) + ] ++ + ([( [ Button (bl+^((-2)*^hv)) + (CmdRotate whs (-1)) + [("turn",hu+^neg hw),("cw",hu+^neg hv)] + , Button (bl+^((-2)*^hw)) + (CmdRotate whs 1) + [("turn",hu+^neg hw),("ccw",hu+^neg hv)] + ], (5,0) ) | whs /= WHSWrench]) ++ + ([( [ Button (bl+^(2*^hv)+^hw+^neg hu) CmdToggle [("swap",hu+^neg hw),("tool",hu+^neg hv)] + ], (2,0) ) | whs == WHSSelected && mode /= IMEdit]) + tr = periphery 0 + tl = periphery 2 + bl = periphery 3 + br = periphery 5 + +markButtonGroup = ([Button (tl+^hw) CmdMark [("set",hu+^neg hw),("mark",hu+^neg hv)] + , Button (tl+^hw+^hv) CmdJumpMark [("jump",hu+^neg hw),("mark",hu+^neg hv)] + , Button (tl+^hw+^2*^hv) CmdReset [("jump",hu+^neg hw),("start",hu+^neg hv)]],(0,1)) + where + tl = periphery 2 + +data AccessedInfo = AccessedSolved | AccessedPublic | AccessedReadNotes | AccessedUndeclared + deriving (Eq, Ord, Show) +data Selectable + = SelOurLock + | SelTut Bool + | SelInitLock HexVec Bool + | SelLock ActiveLock + | SelLockUnset Bool ActiveLock + | SelSelectedCodeName Codename + | SelRelScore + | SelRelScoreComponent + | SelScoreLock (Maybe Codename) (Maybe AccessedReason) ActiveLock + | SelUndeclared Undeclared + | SelReadNote NoteInfo + | SelReadNoteSlot + | SelSolution NoteInfo + | SelAccessed Codename + | SelRandom Codename + | SelSecured NoteInfo + | SelOldLock LockSpec + | SelPublicLock + | SelAccessedInfo AccessedInfo + | SelLockPath + | SelPrivyHeader + | SelNotesHeader + | SelToolHook + | SelToolWrench Bool + deriving (Eq, Ord, Show) + +registerSelectable :: HexVec -> Int -> Selectable -> UIM () +registerSelectable v r s = + modify $ \ds -> ds {registeredSelectables = foldr ( + (`Map.insert` s) . (v+^)) (registeredSelectables ds) (hexDisc r)} +registerButtonGroup :: ButtonGroup -> UIM () +registerButtonGroup g = modify $ \ds -> ds {contextButtons = g:contextButtons ds} +registerButton :: HexVec -> Command -> Int -> [ButtonHelp] -> UIM () +registerButton pos cmd col helps = registerButtonGroup $ singleButton pos cmd col helps +clearSelectables,clearButtons :: UIM () +clearSelectables = modify $ \ds -> ds {registeredSelectables = Map.empty} +clearButtons = modify $ \ds -> ds {contextButtons = []} + +registerUndoButtons :: Bool -> UIM () +registerUndoButtons noRedo = do + registerButton (periphery 2+^hu) CmdUndo 0 [("undo",hu+^neg hw)] + unless noRedo $ registerButton (periphery 2+^hu+^neg hv) CmdRedo 2 [("redo",hu+^neg hw)] + +commandOfSelectable IMInit (SelTut _) _ = Just . CmdSolveInit $ Just zero +commandOfSelectable IMInit (SelInitLock v _) _ = Just . CmdSolveInit $ Just v +commandOfSelectable IMMeta SelOurLock _ = Just CmdEdit +commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) False = Just $ CmdSolve (Just i) +commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) True = Just $ CmdPlaceLock (Just i) +commandOfSelectable IMMeta (SelScoreLock Nothing _ (ActiveLock _ i)) False = Just $ CmdSolve (Just i) +commandOfSelectable IMMeta (SelScoreLock Nothing _ (ActiveLock _ i)) True = Just $ CmdPlaceLock (Just i) +commandOfSelectable IMMeta (SelScoreLock (Just _) _ _) _ = Just CmdHome +commandOfSelectable IMMeta (SelLockUnset True (ActiveLock _ i)) _ = Just $ CmdPlaceLock (Just i) +commandOfSelectable IMMeta (SelSelectedCodeName _) False = Just $ CmdSelCodename Nothing +commandOfSelectable IMMeta (SelSelectedCodeName _) True = Just CmdHome +commandOfSelectable IMMeta (SelUndeclared undecl) _ = Just $ CmdDeclare $ Just undecl +commandOfSelectable IMMeta (SelReadNote note) False = Just $ CmdSelCodename $ Just $ noteAuthor note +commandOfSelectable IMMeta (SelReadNote note) True = Just $ CmdViewSolution $ Just note +commandOfSelectable IMMeta (SelSolution note) False = Just $ CmdSelCodename $ Just $ noteAuthor note +commandOfSelectable IMMeta (SelSolution note) True = Just $ CmdViewSolution $ Just note +commandOfSelectable IMMeta (SelAccessed name) _ = Just $ CmdSelCodename $ Just name +commandOfSelectable IMMeta (SelRandom name) _ = Just $ CmdSelCodename $ Just name +commandOfSelectable IMMeta (SelSecured note) False = Just $ CmdSelCodename $ Just $ lockOwner $ noteOn note +commandOfSelectable IMMeta (SelSecured note) True = Just $ CmdViewSolution $ Just note +commandOfSelectable IMMeta (SelOldLock ls) _ = Just $ CmdPlayLockSpec $ Just ls +commandOfSelectable IMMeta SelLockPath _ = Just CmdSelectLock +commandOfSelectable IMTextInput (SelLock (ActiveLock _ i)) _ = Just $ CmdInputSelLock i +commandOfSelectable IMTextInput (SelScoreLock _ _ (ActiveLock _ i)) _ = Just $ CmdInputSelLock i +commandOfSelectable IMTextInput (SelLockUnset _ (ActiveLock _ i)) _ = Just $ CmdInputSelLock i +commandOfSelectable IMTextInput (SelReadNote note) _ = Just $ CmdInputCodename $ noteAuthor note +commandOfSelectable IMTextInput (SelSolution note) _ = Just $ CmdInputCodename $ noteAuthor note +commandOfSelectable IMTextInput (SelSecured note) _ = Just $ CmdInputCodename $ lockOwner $ noteOn note +commandOfSelectable IMTextInput (SelRandom name) _ = Just $ CmdInputCodename name +commandOfSelectable IMTextInput (SelUndeclared undecl) _ = Just $ CmdInputSelUndecl undecl +commandOfSelectable _ _ _ = Nothing + +helpOfSelectable (SelTut False) = Just "Enter tutorials" +helpOfSelectable (SelTut True) = Just "Revisit tutorials" +helpOfSelectable (SelInitLock _ False) = Just "Attempt lock" +helpOfSelectable (SelInitLock _ True) = Just "Revisit solved lock" +helpOfSelectable SelOurLock = Just + "Design a lock." +helpOfSelectable (SelSelectedCodeName name) = Just $ + "Currently viewing player "++name++"." +helpOfSelectable SelRelScore = Just + "The extent to which you are held in higher esteem than this player." +helpOfSelectable SelRelScoreComponent = Just + "Contribution to total relative esteem." +helpOfSelectable (SelLock (ActiveLock name i)) = Just $ + name++"'s lock "++[lockIndexChar i]++"." +helpOfSelectable (SelLockUnset True _) = Just + "Place a lock." +helpOfSelectable (SelLockUnset False _) = Just + "An empty lock slot." +helpOfSelectable (SelUndeclared _) = Just + "Declare your solution to a lock by securing a note on it behind a lock of your own." +helpOfSelectable (SelRandom _) = Just + "Random set of players. Colours show relative esteem, bright red (-3) to bright green (+3)." +helpOfSelectable (SelScoreLock (Just name) Nothing _) = Just $ + "Your lock. "++name++" can not not unlock it." +helpOfSelectable (SelScoreLock (Just name) (Just AccessedPrivy) _) = Just $ + "Your lock. "++name++" can unlock it: -1 to relative esteem." +helpOfSelectable (SelScoreLock (Just _) (Just AccessedPub) _) = Just + "Your lock. Its secrets have been publically revealed: -1 to relative esteem." +helpOfSelectable (SelScoreLock (Just name) (Just AccessedEmpty) _) = Just $ + "Your empty lock slot. "++name++" can unlock all your locks: -1 to relative esteem." +helpOfSelectable (SelScoreLock Nothing Nothing (ActiveLock name _)) = Just $ + name++"'s lock. You can not unlock it." +helpOfSelectable (SelScoreLock Nothing (Just AccessedPrivy) (ActiveLock name _)) = Just $ + name++"'s lock. You can unlock it: +1 to relative esteem." +helpOfSelectable (SelScoreLock Nothing (Just AccessedPub) (ActiveLock name _)) = Just $ + name++"'s lock. Its secrets have been publically revealed: +1 to relative esteem." +helpOfSelectable (SelScoreLock Nothing (Just AccessedEmpty) (ActiveLock name _)) = Just $ + name++"'s empty lock slot. You can unlock all "++name++"'s locks: +1 to relative esteem." +helpOfSelectable (SelReadNote note) = Just $ + "You have read "++noteAuthor note++"'s note on this lock." +helpOfSelectable SelReadNoteSlot = Just + "Reading three notes on this lock would suffice to reveal its secrets." +helpOfSelectable (SelSecured note) = let ActiveLock owner idx = noteOn note in + Just $ "Secured note on "++owner++"'s lock "++[lockIndexChar idx]++"." +helpOfSelectable (SelSolution note) = Just $ case noteBehind note of + Just (ActiveLock owner idx) -> owner ++ + " has secured their note on this lock behind their lock " ++ [lockIndexChar idx] ++ "." + Nothing -> noteAuthor note ++ "'s note on this lock is public knowledge." +helpOfSelectable (SelAccessed name) = Just $ + name ++ " did not pick this lock, but learnt how to unlock it by reading three notes on it." +helpOfSelectable SelPublicLock = Just + "Notes behind retired or public locks are public; a lock with three public notes on it is public." +helpOfSelectable (SelAccessedInfo meth) = Just $ case meth of + AccessedSolved -> "You picked this lock and declared your solution, so may read any notes it secures." + AccessedPublic -> "The secrets of this lock have been publically revealed." + AccessedUndeclared -> "You have picked this lock, but are yet to declare your solution." + AccessedReadNotes -> + "Having read three notes on others' solutions to this lock, you have unravelled its secrets." +helpOfSelectable (SelOldLock ls) = Just $ + "Retired lock #"++show ls++". Any notes which were secured by the lock are now public knowledge." +helpOfSelectable SelLockPath = Just + "Select a lock by its name. The names you give your locks are not revealed to others." +helpOfSelectable SelPrivyHeader = Just + "Notes on this lock declared by players who picked the lock." +helpOfSelectable SelNotesHeader = Just + "Notes secured by this lock. These notes are read by everyone who can unlock the lock." +helpOfSelectable (SelToolWrench False) = Just "The wrench, one of your lockpicking tools. Click and drag to move." +helpOfSelectable (SelToolWrench True) = Just "The wrench, currently in motion. It will keep moving until it is blocked." +helpOfSelectable SelToolHook = Just "The hook, one of your lockpicking tools. Click and drag to move, use mousewheel to turn." + +cmdAtMousePos (mPos,central) im selMode = do + buttons <- concatMap fst <$> getButtons im + sels <- gets registeredSelectables + return $ listToMaybe $ + [ buttonCmd button + | button <- buttons, mPos == buttonPos button, central] + ++ maybe [] (\isRight -> + [ cmd + | Just sel <- [Map.lookup mPos sels] + , Just cmd <- [ commandOfSelectable im sel isRight ] ]) + selMode + +helpAtMousePos :: (HexVec, Bool) -> InputMode -> UIM (Maybe [Char]) +helpAtMousePos (mPos,_) _ = do + lb <- gets $ isJust . leftButtonDown + gets $ (helpOfSelectableFiltered lb <=< Map.lookup mPos) . registeredSelectables + where + -- Don't show tool help while dragging + helpOfSelectableFiltered True SelToolHook = Nothing + helpOfSelectableFiltered True (SelToolWrench _) = Nothing + helpOfSelectableFiltered _ s = helpOfSelectable s + + +data UIOptButton a = UIOptButton { getUIOpt :: UIOptions->a, setUIOpt :: a->UIOptions->UIOptions, + uiOptVals :: [a], uiOptPos :: HexVec, uiOptGlyph :: a->Glyph, uiOptDescr :: a->String, + uiOptModes :: [InputMode], onSet :: Maybe (a -> UIM ()) } + +-- non-uniform type, so can't use a list... +uiOB1 = UIOptButton useFiveColouring (\v o -> o {useFiveColouring=v}) [True,False] + (periphery 0 +^ 3 *^ hu +^ neg hv) UseFiveColourButton + (\v -> if v then "Adjacent pieces get different colours" else + "Pieces are coloured according to type") + [] -- disabled + Nothing +uiOB2 = UIOptButton showBlocks (\v o -> o {showBlocks=v}) [ShowBlocksBlocking,ShowBlocksAll,ShowBlocksNone] + (periphery 0 +^ 2 *^ hu +^ 2 *^ neg hv) ShowBlocksButton + (\case + ShowBlocksBlocking -> "Showing conflicting forces" + ShowBlocksAll -> "Showing conflicting forces and movements they prevent" + ShowBlocksNone -> "Not showing conflicts") + [IMPlay, IMReplay] Nothing +uiOB3P = UIOptButton ((!? IMPlay) . whsButtons) (\v o -> o { whsButtons = Map.alter (const v) IMPlay $ whsButtons o }) + [Nothing, Just WHSSelected, Just WHSHook, Just WHSWrench] + (periphery 3 +^ 3 *^ hv) WhsButtonsButton + (\case + Nothing -> "Click to show (and rebind) keyboard control buttons." + Just whs -> "Showing buttons for controlling " ++ case whs of + WHSSelected -> "selected piece; right-click on buttons to rebind" + WHSWrench -> "wrench; right-click on buttons to rebind" + WHSHook -> "hook; right-click on buttons to rebind") + [IMPlay] Nothing +uiOB3E = UIOptButton ((!? IMEdit) . whsButtons) (\v o -> o { whsButtons = Map.alter (const v) IMEdit $ whsButtons o }) + [Nothing, Just WHSSelected] + (periphery 3 +^ 3 *^ hv) WhsEditButtonsButton + (\case + Nothing -> "Click to show (and rebind) keyboard control buttons." + Just _ -> "Showing buttons for controlling cursor / selected piece; right-click on buttons to rebind") + [IMEdit] Nothing +uiOB4 = UIOptButton showButtonText (\v o -> o {showButtonText=v}) [True,False] + (periphery 0 +^ 2 *^ hu +^ 3 *^ hv) ShowButtonTextButton + (\v -> if v then "Help text enabled" else + "Help text disabled") + [IMPlay, IMEdit, IMReplay, IMMeta, IMInit] Nothing +uiOB5 = UIOptButton fullscreen (\v o -> o {fullscreen=v}) [True,False] + (periphery 0 +^ 4 *^ hu +^ 2 *^ hv) FullscreenButton + (\v -> if v then "Fullscreen mode active" else "Windowed mode active") + [IMPlay, IMEdit, IMReplay, IMMeta, IMInit] (Just onFullScreenChange) +uiOB6 = UIOptButton soundVolume (\v o -> o {soundVolume=v}) [64,0,16,32] + (periphery 0 +^ 4 *^ hu +^ hv) VolumeButton + (\case + v | v >= 64 -> "Sound effects at full volume" + v | v >= 32 -> "Sound effects at medium volume" + 0 -> "Sound effects disabled" + _ -> "Sound effects at low volume") + [IMPlay, IMEdit, IMReplay] $ Just (`setVolume` AllChannels) + +drawUIOptionButtons :: InputMode -> UIM () +drawUIOptionButtons mode = do + drawUIOptionButton mode uiOB1 + drawUIOptionButton mode uiOB2 + drawUIOptionButton mode uiOB3P + drawUIOptionButton mode uiOB3E + drawUIOptionButton mode uiOB4 + drawUIOptionButton mode uiOB5 +#ifdef SOUND + drawUIOptionButton mode uiOB6 +#endif +drawUIOptionButton im b = when (im `elem` uiOptModes b) $ do + value <- gets $ getUIOpt b . uiOptions + renderToMain $ mapM_ (\g -> drawAtRel g (uiOptPos b)) + [HollowGlyph $ obscure purple, uiOptGlyph b value] +describeUIOptionButton :: UIOptButton a -> MaybeT UIM String +describeUIOptionButton b = do + value <- gets $ getUIOpt b . uiOptions + return $ uiOptDescr b value +-- XXX: hand-hacking lenses... +toggleUIOption (UIOptButton getopt setopt vals _ _ _ _ monSet) = do + value <- gets $ getopt . uiOptions + let value' = cycle vals !! max 0 (1 + fromMaybe 0 (elemIndex value vals)) + modifyUIOptions $ setopt value' + maybe (pure ()) ($ value') monSet + +readUIConfigFile :: UIM () +readUIConfigFile = do + path <- liftIO $ confFilePath "SDLUI.conf" + mOpts <- liftIO $ readReadFile path + case mOpts of + Just opts -> modify $ \s -> s {uiOptions = opts} + Nothing -> return () +writeUIConfigFile :: UIM () +writeUIConfigFile = do + path <- liftIO $ confFilePath "SDLUI.conf" + opts <- gets uiOptions + liftIO makeConfDir + liftIO $ writeFile path $ show opts + +readBindings :: UIM () +readBindings = do + path <- liftIO $ confFilePath "bindings" + mbdgs <- liftIO $ readReadFile path + case mbdgs of + Just bdgs -> modify $ \s -> s {uiKeyBindings = bdgs} + Nothing -> return () +writeBindings :: UIM () +writeBindings = do + path <- liftIO $ confFilePath "bindings" + bdgs <- gets uiKeyBindings + liftIO makeConfDir + liftIO $ writeFile path $ show bdgs + +getBindings :: InputMode -> UIM [(Char, Command)] +getBindings mode = do + uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings) + return $ uibdgs ++ bindings mode + +paintTiles :: [ Maybe Tile ] +paintTiles = + [ Just BallTile + , Just $ ArmTile zero False + , Just $ PivotTile zero + , Just $ SpringTile Relaxed zero + , Just $ BlockTile [] + , Nothing + ] + +paintTileCmds = map (maybe CmdDelete CmdTile) paintTiles + +getEffPaintTileIndex :: UIM Int +getEffPaintTileIndex = do + mods <- liftIO getModState + if keyModifierLeftCtrl mods || keyModifierRightCtrl mods + then return $ length paintTiles - 1 + else gets paintTileIndex + +paintButtonStart :: HexVec +paintButtonStart = periphery 0 +^ (- length paintTiles `div` 2)*^hv + +drawPaintButtons :: UIM () +drawPaintButtons = do + pti <- getEffPaintTileIndex + renderToMain $ sequence_ [ + do + let gl = case paintTiles!!i of + Nothing -> HollowInnerGlyph $ dim purple + Just t -> TileGlyph t $ dim purple + drawAtRel gl pos + when selected $ drawAtRel cursorGlyph pos + | i <- take (length paintTiles) [0..] + , let pos = paintButtonStart +^ i*^hv + , let selected = i == pti + ] + +periphery 0 = ((3*maxlocksize)`div`2)*^hu +^ ((3*maxlocksize)`div`4)*^hv +periphery n = rotate n $ periphery 0 +-- ^ XXX only peripheries 0,2,3,5 are guaranteed to be on-screen! +--messageLineStart = (maxlocksize+1)*^hw +messageLineCentre = ((maxlocksize+1)`div`2)*^hw +^ ((maxlocksize+1+1)`div`2)*^neg hv + +-- XXX HACK: the n=8 line is crowded +titlePos n = titlePos' $ if n == 8 then 9 else n + where titlePos' l = l*^hv +^ (l`div`2)*^hu + +screenWidthHexes,screenHeightHexes :: CInt +screenWidthHexes = 32 +screenHeightHexes = 26 +getGeom :: UIM (SVec, CInt) +getGeom = do + V2 w h <- gets scrDimen + let scrCentre = SVec (w`div`2) (h`div`2) + -- |size is the greatest integer such that + -- and [2*size*screenWidthHexes < width + -- , 3*ysize size*screenHeightHexes < height] + -- where ysize size = round $ fi size / sqrt 3 + -- Minimum allowed size is 2 (get segfaults on SDL_FreeSurface with 1). + let size = max 2 $ min ((w-1)`div`(2*screenWidthHexes)) + (floor $ sqrt 3 * (0.5 + fi ((h-1)`div`(3*screenHeightHexes)))) + return (scrCentre, size) + +clearAnim :: UIM () +clearAnim = modify $ \ds -> ds { animFrame = 0, nextAnimFrameAt = Nothing } + +data DrawArgs = DrawArgs [PieceIdx] Bool [Alert] GameState UIOptions + deriving (Eq, Ord, Show) + +drawMainGameState :: [PieceIdx] -> Bool -> [Alert] -> GameState -> UIM () +drawMainGameState highlight colourFixed alerts st = do + uiopts <- gets uiOptions + drawMainGameState' $ DrawArgs highlight colourFixed alerts st uiopts + +data AnimFrameInfo = AnimFrameInfo + { animFrameAlerts :: [Alert] + , animFrameState :: GameState + , animFrameIsIntermediate :: Bool + } deriving Eq + +drawMainGameState' :: DrawArgs -> UIM () +drawMainGameState' args@(DrawArgs highlight colourFixed alerts st uiopts) = do + lastArgs <- gets lastDrawArgs + when (case lastArgs of + Nothing -> True + Just (DrawArgs _ _ lastAlerts lastSt _) -> + lastAlerts /= alerts || lastSt /= st) + clearAnim + modify $ \ds -> ds { lastDrawArgs = Just args } + + lastAnimFrame <- gets animFrame + now <- ticks + anim <- gets (maybe False ( ds { animFrame = lastAnimFrame+1, nextAnimFrameAt = Nothing } + animFrameToDraw <- gets animFrame + + noJiggle <- gets $ not . jiggleBlocked . uiOptions + + -- split the alerts at intermediate states, and associate alerts + -- to the right states: + let (globalAlerts,transitoryAlerts) = partition isGlobalAlert alerts + splitAlerts :: [Alert] -> [Alert] -> [AnimFrameInfo] + splitAlerts frameAs (AlertIntermediateState st' : as) = + AnimFrameInfo frameAs st' True : splitAlerts [] as + splitAlerts frameAs (a:as) = + splitAlerts (a:frameAs) as + splitAlerts frameAs [] = [AnimFrameInfo frameAs st False] + jiggleLast :: [AnimFrameInfo] -> [AnimFrameInfo] + jiggleLast afis | noJiggle = afis + jiggleLast [AnimFrameInfo as st' False] + | jiggles <- nub $ mapMaybe blockedToForce globalAlerts + , not (null jiggles) + = [ AnimFrameInfo jiggles st' True + , AnimFrameInfo as st' False] + jiggleLast (af:afs) = af : jiggleLast afs + jiggleLast [] = [] + isGlobalAlert (AlertAppliedForce _) = False + isGlobalAlert (AlertIntermediateState _) = False + isGlobalAlert _ = True + blockedToForce (AlertBlockedForce (Push idx dir)) = Just $ AlertAppliedForce (Push idx $ neg dir) + blockedToForce (AlertBlockedForce (Torque idx tdir)) = Just $ AlertAppliedForce (Torque idx $ -tdir) + blockedToForce _ = Nothing + let animAlertedStates = jiggleLast $ nub $ + let ass = splitAlerts [] transitoryAlerts + in if last ass == AnimFrameInfo [] st False then ass else ass ++ [AnimFrameInfo [] st False] + let frames = length animAlertedStates + let AnimFrameInfo drawAlerts' drawSt isIntermediate = animAlertedStates !! animFrameToDraw + let drawAlerts = nub $ drawAlerts' ++ globalAlerts + -- let drawAlerts = takeWhile (/= AlertIntermediateState drawSt) alerts + nextIsSet <- gets (isJust . nextAnimFrameAt) + when (not nextIsSet && frames > animFrameToDraw+1) $ do + t <- gets ((if isIntermediate then uiAnimTime else shortUiAnimTime) . uiOptions) + modify $ \ds -> ds { nextAnimFrameAt = Just $ now + t } + + let board = stateBoard drawSt + lastCol <- gets dispLastCol + let coloured = colouredPieces colourFixed drawSt + let colouring = if useFiveColouring uiopts + then boardColouring drawSt coloured lastCol + else pieceTypeColouring drawSt coloured + modify $ \ds -> ds { dispLastCol = colouring } + renderToMain $ do + let tileGlyphs = ownedTileGlyph colouring highlight <$> board + + applyAlert (AlertAppliedForce (Torque idx tdir)) = + let poss = case getpp drawSt idx of + PlacedPiece pos (Pivot arms) -> pos : map (+^pos) arms + PlacedPiece pos (Hook arm _) -> [arm+^pos] + _ -> [] + rotateGlyph (TileGlyph (ArmTile dir _) col) = + ArmGlyph (-tdir) dir col + rotateGlyph (TileGlyph (PivotTile dir) col) = + PivotGlyph (-tdir) dir col + rotateGlyph gl = gl + in flip (foldr . Map.adjust $ rotateGlyph) poss + applyAlert (AlertAppliedForce (Push idx dir)) = + displaceFootprint . displaceSprings + where + displace = DisplacedGlyph $ neg dir + displaceSpringGlyph isRoot (TileGlyph (SpringTile extn sdir) col) = + displaceSpringGlyph isRoot $ SpringGlyph zero zero extn sdir col + displaceSpringGlyph isRoot (SpringGlyph rdisp edisp extn sdir col) + | isRoot = SpringGlyph (neg dir) edisp extn sdir col + | otherwise = SpringGlyph rdisp (neg dir) extn sdir col + displaceSpringGlyph _ glyph = glyph + displaceFootprint = + flip (foldr . Map.adjust $ displace) $ + plPieceFootprint $ getpp drawSt idx + + displaceSpring isRoot c@(Connection root end (Spring sdir _)) + | dir `elem` [sdir,neg sdir] = + Map.adjust (displaceSpringGlyph isRoot) $ + if isRoot + then sdir +^ locusPos drawSt root + else neg sdir +^ locusPos drawSt end + | isRoot = + flip (foldr . Map.adjust $ displace) $ + connectionFootPrint drawSt c + | otherwise = id + displaceSpring _ _ = id + + displaceSprings = + flip (foldr $ displaceSpring True) (springsRootAtIdx drawSt idx) . + flip (foldr $ displaceSpring False) (springsEndAtIdx drawSt idx) + applyAlert _ = id + + applyAlerts = flip (foldr applyAlert) drawAlerts + + erase + sequence_ [ drawAt glyph pos | + (pos,glyph) <- Map.toList $ applyAlerts tileGlyphs + ] + + when (showBlocks uiopts /= ShowBlocksNone) $ sequence_ $ + [ drawBlocked drawSt colouring False force + | showBlocks uiopts == ShowBlocksAll + , AlertBlockedForce force <- drawAlerts] ++ + [ drawBlocked drawSt colouring True force + | AlertBlockingForce force <- drawAlerts ] ++ + -- [ drawBlocked drawSt colouring True force + -- | AlertResistedForce force <- drawAlerts ] ++ + [ drawAt CollisionMarker pos + | AlertCollision pos <- drawAlerts ] + -- [ drawApplied drawSt colouring force + -- | AlertAppliedForce force <- drawAlerts ] ++ + +playAlertSounds :: GameState -> [Alert] -> UIM () +#ifdef SOUND +playAlertSounds st alerts = do + use <- gets $ (> 0) . soundVolume . uiOptions + when use $ mapM_ (maybe (return ()) playSound . alertSound) alerts + where + alertSound (AlertBlockedForce force) = alertPreventedForce force + alertSound (AlertResistedForce force) = alertPreventedForce force + alertSound (AlertDivertedWrench _) = Just "wrenchscrape" + alertSound (AlertAppliedForce (Torque idx _)) + | isPivot.placedPiece.getpp st $ idx = Just "pivot" + | isTool.placedPiece.getpp st $ idx = Just "toolmove" + alertSound (AlertAppliedForce (Push idx dir)) + | isBall.placedPiece.getpp st $ idx = Just "ballmove" + | isTool.placedPiece.getpp st $ idx = Just "toolmove" + | otherwise = do + (align,newLen) <- listToMaybe [(align,newLen) + | c@(Connection (startIdx,_) (endIdx,_) (Spring outDir _)) <- connections st + , let align = (if outDir == dir then 1 else if outDir == neg dir then -1 else 0) + * (if idx == startIdx then 1 else if idx == endIdx then -1 else 0) + , align /= 0 + , let newLen = connectionLength st c ] + return $ "spring" ++ (if align == 1 then "contract" else "extend") + ++ show (min newLen 12) + alertSound AlertUnlocked = Just "unlocked" + alertSound _ = Nothing + alertPreventedForce force = + let PlacedPiece _ piece = getpp st $ forceIdx force + in case piece of + Wrench _ -> Just "wrenchblocked" + Hook _ _ -> if isPush force then Just "hookblocked" else Just "hookarmblocked" + _ -> Nothing + playSound :: String -> UIM () + playSound sound = void.runMaybeT $ do + ss <- MaybeT $ Map.lookup sound <$> gets sounds + guard.not.null $ ss + liftIO $ randFromList ss >>= \(Just s) -> handleAll (const $ pure ()) $ play s + randFromList :: [a] -> IO (Maybe a) + randFromList [] = return Nothing + randFromList as = (Just.(as!!)) <$> randomRIO (0,length as - 1) +#else +playAlertSounds _ _ = return () +#endif + + +drawMiniLock :: Lock -> HexVec -> UIM () +drawMiniLock lock v = do + texture <- maybe new return =<< gets ((SC.!? lock) . miniLocks) + renderToMain $ blitAt texture v + where + miniLocksize = 3 + new = do + (_, size) <- getGeom + let minisize = size `div` ceiling (lockSize lock % miniLocksize) + let width, height :: CInt + width = size*2*(fi miniLocksize*2+1) + height = ceiling $ fi size * sqrt 3 * fi (miniLocksize*2+1+1) + surf <- createRGBSurface (V2 width height) =<< masksToPixelFormat 16 (V4 0 0 0 0) + surfaceColorKey surf $= Just (V4 0 0 0 0) + rend <- createSoftwareRenderer surf + uiopts <- gets uiOptions + let st = snd $ reframe lock + coloured = colouredPieces False st + colouring = if useFiveColouring uiopts + then boardColouring st coloured Map.empty + else pieceTypeColouring st coloured + draw = sequence_ [ drawAt glyph pos | + (pos,glyph) <- Map.toList $ ownedTileGlyph colouring [] <$> stateBoard st ] + liftIO $ do + (_,cache) <- runRenderM draw emptyRenderCache $ + RenderContext rend Nothing (PHS zero) (SVec (width`div`2) (height`div`2)) zero minisize Nothing width + deallocRenderCache cache + destroyRenderer rend + Just vidRend <- gets vidRenderer + texture <- createTextureFromSurface vidRend surf + minis <- liftIO . SC.insert lock texture =<< gets miniLocks + modify $ \ds -> ds { miniLocks = minis } + return texture + +clearMiniLocks = do + liftIO . SC.deallocAll =<< gets miniLocks + modify $ \ds -> ds { miniLocks = emptyMiniLocks } + +drawEmptyMiniLock v = + renderToMain $ recentreAt v $ rescaleRender 6 $ drawAtRel (HollowInnerGlyph $ dim white) zero + +getBindingStr :: InputMode -> UIM (Command -> String) +getBindingStr mode = do + setting <- gets settingBinding + uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings) + return (\cmd -> + if Just cmd == setting then "??" + else maybe "" showKeyFriendlyShort $ findBinding (uibdgs ++ bindings mode) cmd) + +drawButtons :: InputMode -> UIM () +drawButtons mode = do + buttons <- getButtons mode + bindingStr <- getBindingStr mode + showBT <- gets (showButtonText . uiOptions) + smallFont <- gets dispFontSmall + renderToMain $ sequence_ $ concat [ [ do + drawAtRel (ButtonGlyph col) v + let drawBdg = renderStrColAt buttonTextCol bdg v + case length bdg of + 0 -> drawAtRel UnboundButtonGlyph v + l | l < 3 -> drawBdg + _ -> withFont smallFont drawBdg + when showBT $ + withFont smallFont $ recentreAt v $ rescaleRender (1/4) $ + sequence_ [ renderStrColAtLeft white s dv | (s,dv) <- helps ] + | (i,(v,bdg,helps)) <- enumerate $ map (\b->(buttonPos b, bindingStr $ buttonCmd b, buttonHelp b)) buttonGroup + , let col = dim $ colourWheel (base+inc*i) ] + | (buttonGroup,(base,inc)) <- buttons + ] + where enumerate = zip [0..] + +initMisc :: UIM () +initMisc = do + mevType <- registerEvent (const . const . pure $ Just ()) (const . pure $ RegisteredEventData Nothing 0 nullPtr nullPtr) + modify $ \s -> s { unblockEventType = mevType } + +onFullScreenChange :: Bool -> UIM () +onFullScreenChange fs = do + Just win <- gets sdlWindow + setWindowMode win $ wModeOfFS fs + initVideo 0 0 +wModeOfFS :: Bool -> WindowMode +wModeOfFS True = FullscreenDesktop +wModeOfFS False = Windowed + +initVideo :: CInt -> CInt -> UIM () +initVideo w h = do + winUninitialised <- gets $ isNothing . sdlWindow + when winUninitialised $ do + wMode <- gets $ wModeOfFS . fullscreen . uiOptions + let winConf = defaultWindow + { windowMode = wMode + , windowResizable = True + , windowInitialSize = if (w,h) == (0,0) then V2 800 600 else V2 w h + } + win <- createWindow "Intricacy" winConf + rend <- createRenderer win (-1) defaultRenderer + modify $ \ds -> ds { sdlWindow = Just win, vidRenderer = Just rend } + + Just win <- gets sdlWindow + Just vidRend <- gets vidRenderer + + dimen <- SDL.get (windowSize win) + modify $ \ds -> ds { scrDimen = dimen } + + maybe (pure ()) destroyTexture =<< gets backbuffer + bb <- createTexture vidRend RGB888 TextureAccessTarget dimen + rendererRenderTarget vidRend $= Just bb + modify $ \ds -> ds { backbuffer = Just bb } + + clearFrame >> refresh + + (_,size) <- getGeom +#ifdef EMBED + font <- warnIOErrAlt $ Just <$> TTF.decode veraMoBd (fi size) + smallFont <- warnIOErrAlt $ Just <$> TTF.decode veraMoBd (2 * fi size `div` 3) +#else + fontpath <- liftIO $ getDataPath "VeraMoBd.ttf" + font <- warnIOErrAlt $ Just <$> TTF.load fontpath (fi size) + smallFont <- warnIOErrAlt $ Just <$> TTF.load fontpath (2 * fi size `div` 3) +#endif + modify $ \ds -> ds { dispFont = font, dispFontSmall = smallFont } + + maybe (pure ()) destroyTexture =<< gets bgTexture + useBG <- gets $ useBackground . uiOptions + mbg <- if useBG then do + bgsurf <- createRGBSurface dimen =<< masksToPixelFormat 16 (V4 0 0 0 0) + bgrend <- createSoftwareRenderer bgsurf + (_,cache) <- renderToMainWithRenderer bgrend emptyRenderCache . drawBasicBG . fi $ 2*max screenWidthHexes screenHeightHexes`div`3 + liftIO $ deallocRenderCache cache -- XXX: have to destroy textures before renderer + destroyRenderer bgrend + bgtexture <- createTextureFromSurface vidRend bgsurf + freeSurface bgsurf + pure $ Just bgtexture + else return Nothing + modify $ \ds -> ds { bgTexture = mbg } + + clearMiniLocks + liftIO . deallocRenderCache =<< gets rCache + modify $ \s -> s { rCache = emptyRenderCache } + + when (isNothing font) $ liftIO $ do + now <- getCurrentTime +#ifdef EMBED + let text = show now ++ ": Warning: embedded font failed to load.\n" +#else + let text = show now ++ ": Warning: font file not found at "++fontpath++".\n" +#endif + putStr text + appendFile "intricacy-warnings.log" text + +initAudio :: UIM () +#ifdef SOUND +initAudio = do + initialised <- (isJust <$>) . nothingOnIOErr $ openAudio (defaultAudio { audioOutput = SDL.Mixer.Mono }) 1024 + unless initialised $ liftIO $ do + now <- getCurrentTime + let text = show now ++ ": Warning: audio failed to initialise.\n" + putStr text + appendFile "intricacy-warnings.log" text + -- liftIO $ querySpec >>= print + setChannels 32 + let seqWhileJust (m:ms) = m >>= \ret -> case ret of + Nothing -> return [] + Just a -> (a:) <$> seqWhileJust ms + seqWhileJust [] = pure [] + soundsdir <- liftIO $ getDataPath "sounds" + globalVolume <- gets $ soundVolume . uiOptions + snds <- sequence [ do + chunks <- seqWhileJust + [ runMaybeT $ do + chunk <- msum $ map (MaybeT . nothingOnIOErr . load) paths + setVolume vol chunk + return chunk + | n <- [1..] + , let paths = [soundsdir ++ [pathSeparator] ++ sound ++ + "-" ++ (if n < 10 then ('0':) else id) (show n) ++ ext + | ext <- [".ogg", ".wav"] ] + , let vol = case sound of + "pivot" -> 64 + "wrenchscrape" -> 64 + "wrenchblocked" -> 64 + "hookarmblocked" -> 64 + "hookblocked" -> 64 + "toolmove" -> 64 + _ -> 128 + ] + setVolume globalVolume AllChannels + return (sound,chunks) + | sound <- ["hookblocked","hookarmblocked","wrenchblocked","wrenchscrape","pivot","unlocked","ballmove","toolmove"] + ++ ["spring" ++ d ++ show l | d <- ["extend","contract"], l <- [1..12]] ] + modify $ \s -> s { sounds = Map.fromList snds } +#else +initAudio = return () +#endif + +drawMsgLine = void.runMaybeT $ do + (col,str) <- msum + [ MaybeT $ gets message + , (dimWhiteCol,) <$> MaybeT (gets hoverStr) + ] + lift $ do + renderToMain $ blankRow messageLineCentre + smallFont <- gets dispFontSmall + renderToMain $ + (if length str > fi screenWidthHexes * 3 then withFont smallFont else id) $ + renderStrColAtCentre col str messageLineCentre + +setMsgLineNoRefresh col str = do + modify $ \s -> s { message = Just (col,str) } + drawMsgLine +setMsgLine col str = setMsgLineNoRefresh col str >> refresh + +clearMsg :: UIM () +clearMsg = modify $ \s -> s { message = Nothing } + +drawTitle (Just (title,n)) = renderToMain $ renderStrColAtCentre messageCol title (titlePos n) +drawTitle Nothing = return () + +say = setMsgLine messageCol +sayError = setMsgLine errorCol + +miniLockPos = (-9)*^hw +^ hu +lockLinePos = 4*^hu +^ miniLockPos +serverPos = 12*^hv +^ 7*^neg hu +serverWaitPos = serverPos +^ hw +^ hu +randomNamesPos = 9*^hv +^ 2*^ neg hu +codenamePos = (-6)*^hw +^ 6*^hv +undeclsPos = 13*^neg hu +accessedOursPos = 2*^hw +^ codenamePos +locksPos = hw+^neg hv +retiredPos = locksPos +^ 11*^hu +^ neg hv +interactButtonsPos = 9*^neg hu +^ 8*^hw +scoresPos = codenamePos +^ 5*^hu +^ 2*^neg hv diff --git a/SDL2UIMInstance.hs b/SDL2UIMInstance.hs new file mode 100644 --- /dev/null +++ b/SDL2UIMInstance.hs @@ -0,0 +1,956 @@ +-- This file is part of Intricacy +-- Copyright (C) 2013-2025 Martin Bays +-- +-- 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/. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module SDL2UIMInstance () where + +import Control.Applicative +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.State +import Control.Monad.Trans.Maybe +import Data.Array +import Data.Foldable (for_) +import Data.Function (on) +import Data.List +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Vector as Vector +import Safe (maximumBound) +import SDL hiding (get, rotate, zero, (*^)) +import qualified SDL.Font as TTF +import SDL.Primitive (Color) +import System.Timeout +--import Debug.Trace (traceShow) + +import Cache +import Command +import Database +import GameStateTypes +import Hex +import InputMode +import KeyBindings +import MainState +import Metagame +import Mundanities +import Protocol +import SDL2Glyph +import SDL2Keys +import SDL2Render +import SDL2RenderCache +import SDL2UI +import ServerAddr +import Util + +instance UIMonad (StateT UIState IO) where + runUI m = evalStateT m nullUIState + drawMainState = do + lift clearFrame + lift $ clearButtons >> clearSelectables + s <- get + let mode = ms2im s + lift waitFrame + drawMainState' s + lift . drawTitle =<< getTitle + lift $ do + drawButtons mode + drawUIOptionButtons mode + updateHoverStr mode + drawMsgLine + drawShortMouseHelp mode s + refresh + clearMessage = clearMsg + drawMessage = say + drawPrompt full s = say $ s ++ (if full then "" else "_") + endPrompt = clearMsg + drawError = sayError + + reportAlerts = playAlertSounds + onPhysicsTick = clearAnim + + getChRaw = resetMouseButtons >> liftIO getChRaw' + where + resetMouseButtons = modify $ \s -> s + { leftButtonDown = Nothing + , middleButtonDown = Nothing + , rightButtonDown = Nothing + } + getChRaw' = do + events <- (eventPayload <$>) <$> getEvents + if or [ True | MouseButtonEvent dat <- events + , mouseButtonEventMotion dat == Pressed + , mouseButtonEventButton dat == ButtonRight + ] + then return Nothing + else maybe getChRaw' (return.Just) $ listToMaybe $ [ ch + | KeyboardEvent dat <- events + , keyboardEventKeyMotion dat == Pressed + , let ch = keysymChar $ keyboardEventKeysym dat + , ch /= '\0' ] + + setUIBinding mode cmd ch = + modify $ \s -> s { uiKeyBindings = + Map.insertWith (\ [bdg] bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs) + mode [(ch,cmd)] $ uiKeyBindings s } + + getUIBinding mode cmd = ($ cmd) <$> getBindingStr mode + + initUI = (isJust <$>) . runMaybeT $ do + let toInit = [InitVideo, InitEvents, InitTimer] +#ifdef SOUND + <> [InitAudio] +#endif + catchIOErrorMT $ initialize toInit + catchIOErrorMT TTF.initialize + lift $ do + readUIConfigFile + initVideo 0 0 + V2 w h <- gets scrDimen + warpMouse WarpGlobal (P $ V2 (w`div`2) (h`div`2)) + initMisc + renderToMain erase + initAudio + readBindings + where + catchIOErrorMT m = MaybeT . warnIOErrAlt $ m >> return (Just ()) + + endUI = do + writeUIConfigFile + writeBindings + quit + + unblockInput = + gets $ maybe (pure ()) (\(RegisteredEventType push _) -> void $ push ()) . unblockEventType + + suspend = return () + redraw = return () + + impatience t = do + liftIO $ threadDelay 50000 + if t>20 then do + let pos = serverWaitPos + smallFont <- gets dispFontSmall + renderToMain $ do + mapM_ (drawAtRel (FilledHexGlyph $ bright black)) [ pos +^ i*^hu | i <- [0..3] ] + withFont smallFont $ + renderStrColAtLeft errorCol ("waiting..."++replicate ((t`div`5)`mod`3) '.') pos + clearButtons + registerButton (pos +^ neg hv) CmdQuit 0 [("abort",hu+^neg hw)] + drawButtons IMImpatience + refresh + cmds <- getInput IMImpatience + return $ CmdQuit `elem` cmds + else return False + + warpPointer pos = do + (scrCentre, size) <- getGeom + centre <- gets dispCentre + let SVec x y = hexVec2SVec size (pos-^centre) +^ scrCentre + Just win <- gets sdlWindow + warpMouse (WarpInWindow win) (P $ V2 x y) + lbp <- gets leftButtonDown + rbp <- gets rightButtonDown + let [lbp',rbp'] = ((const $ pos -^ centre) <$>) <$> [lbp,rbp] + modify $ \s -> s {leftButtonDown = lbp', rightButtonDown = rbp'} + + getUIMousePos = do + centre <- gets dispCentre + gets ((Just.(+^centre).fst) . mousePos) + + setYNButtons = do + clearButtons + registerButton (periphery 5 +^ hw +^ neg hv) (CmdInputChar 'Y') 2 [("confirm",hu+^neg hw)] + drawButtons IMTextInput + + toggleColourMode = modify $ \s -> s {uiOptions = (uiOptions s){ + useFiveColouring = not $ useFiveColouring $ uiOptions s}} + + getInputNoBlock = getInput + + getInput mode = do + aimFPS <- gets fps + events <- liftIO $ getEventsTimeout (10^6`div`aimFPS) + unblockEvent <- maybe (pure False) + (\(RegisteredEventType _ getReg) -> not . null . catMaybes <$> mapM (liftIO . getReg) events) + =<< gets unblockEventType + let payloads = nubMouseMotions $ eventPayload <$> events + (cmds,uiChanged) <- if null events then return ([],False) else do + oldUIState <- get + cmds <- concat <$> mapM processEvent payloads + setPaintFromCmds cmds + newUIState <- get + return (cmds,uistatesMayVisiblyDiffer oldUIState newUIState) + now <- ticks + animFrameReady <- gets (maybe False ( s { paintTileIndex = pti } + | (pti,pt) <- zip [0..] paintTiles + , cmd <- cmds + , (isNothing pt && cmd == CmdDelete) || + isJust (do + pt' <- pt + CmdTile t <- Just cmd + guard $ ((==)`on`tileType) t pt') ] + + uistatesMayVisiblyDiffer uis1 uis2 = + proj uis1 /= proj uis2 + where proj uis = (uiOptions uis, settingBinding uis, paintTileIndex uis, message uis, hoverStr uis, dispCentre uis, dispLastCol uis, animFrame uis) + processEvent (KeyboardEvent dat) + | mode == IMEdit + , Keysym _ k _ <- keyboardEventKeysym dat, k `elem` [KeycodeLCtrl, KeycodeRCtrl] = + -- To show paint selection + pure [CmdRefresh] + processEvent (KeyboardEvent dat) + | keyboardEventKeyMotion dat == Pressed + , ch <- keysymChar $ keyboardEventKeysym dat + = case mode of + IMTextInput -> return [CmdInputChar ch] + _ -> do + setting <- gets settingBinding + if isJust setting && ch /= '\0' + then do + modify $ \s -> s {settingBinding = Nothing} + when (ch /= '\ESC') $ setUIBinding mode (fromJust setting) ch + return [] + else do + uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings) + let mCmd = lookup ch $ uibdgs ++ bindings mode + return $ maybeToList mCmd + processEvent (MouseMotionEvent dat) = do + (oldMPos,_) <- gets mousePos + (pos@(mPos,_),(sx,sy,sz)) <- getMousePosAt $ mouseMotionEventPos dat + updateMousePos pos + lbp <- gets leftButtonDown + rbp <- gets rightButtonDown + centre <- gets dispCentre + let drag :: Maybe HexVec -> Maybe Command + drag bp = do + fromPos@(HexVec x y z) <- bp + -- check we've dragged at least a full hex's distance: + guard $ not.all (\(a,b) -> abs (fi a - b) < 1.0) $ [(x,sx),(y,sy),(z,sz)] + let dir = hexVec2HexDirOrZero $ mPos -^ fromPos + guard $ dir /= zero + return $ CmdDrag (fromPos+^centre) dir + case mode of + IMEdit -> case drag rbp of + Just cmd -> return [cmd] + Nothing -> if mPos /= oldMPos + then do + pti <- getEffPaintTileIndex + return $ CmdMoveTo (mPos +^ centre) : + ([CmdPaintFromTo (paintTiles!!pti) (oldMPos+^centre) (mPos+^centre) | isJust lbp]) + else return [] + IMPlay -> return $ maybeToList $ msum $ map drag [lbp, rbp] + _ -> return [] + processEvent (MouseButtonEvent dat) = procMButton + (mouseButtonEventMotion dat) (mouseButtonEventButton dat) (mouseButtonEventPos dat) + processEvent (MouseWheelEvent MouseWheelEventData{ mouseWheelEventPos = V2 _ y, mouseWheelEventDirection = dir }) + = doWheel $ (if dir == ScrollFlipped then -1 else 1) * signum (fi y) + processEvent (WindowSizeChangedEvent (WindowSizeChangedEventData _ (V2 w h))) = do + initVideo (fi w) (fi h) + return [ CmdRedraw ] + processEvent (WindowExposedEvent _) = return [ CmdRefresh ] + processEvent QuitEvent = return [ CmdForceQuit ] + processEvent _ = return [] + + procMButton Pressed ButtonLeft p = do + (pos@(mPos,_),_) <- getMousePosAt p + modify $ \s -> s { leftButtonDown = Just mPos } + rb <- gets (isJust . rightButtonDown) + mcmd <- cmdAtMousePos pos mode (Just False) + let hotspotAction = listToMaybe + $ map (\cmd -> return [cmd]) (maybeToList mcmd) + ++ [ modify (\s -> s {paintTileIndex = i}) >> return [] + | i <- take (length paintTiles) [0..] + , mPos == paintButtonStart +^ i*^hv ] + ++ [ toggleUIOption uiOB1 >> updateHoverStr mode >> return [] + | mPos == uiOptPos uiOB1 && mode `elem` uiOptModes uiOB1 ] + ++ [ toggleUIOption uiOB2 >> updateHoverStr mode >> return [] + | mPos == uiOptPos uiOB2 && mode `elem` uiOptModes uiOB2 ] + ++ [ toggleUIOption uiOB3P >> updateHoverStr mode >> return [] + | mPos == uiOptPos uiOB3P && mode `elem` uiOptModes uiOB3P ] + ++ [ toggleUIOption uiOB3E >> updateHoverStr mode >> return [] + | mPos == uiOptPos uiOB3E && mode `elem` uiOptModes uiOB3E] + ++ [ toggleUIOption uiOB4 >> updateHoverStr mode >> return [] + | mPos == uiOptPos uiOB4 && mode `elem` uiOptModes uiOB4 ] + ++ [ toggleUIOption uiOB5 >> updateHoverStr mode >> return [] + | mPos == uiOptPos uiOB5 && mode `elem` uiOptModes uiOB5 ] +#ifdef SOUND + ++ [ toggleUIOption uiOB6 >> updateHoverStr mode >> return [] + | mPos == uiOptPos uiOB6 && mode `elem` uiOptModes uiOB6 ] +#endif + + if rb + then return [ CmdWait ] + else flip fromMaybe hotspotAction $ case mode of + IMEdit -> do + pti <- getEffPaintTileIndex + return [ drawCmd (paintTiles!!pti) False ] + IMPlay -> do + centre <- gets dispCentre + return [ CmdManipulateToolAt $ mPos +^ centre ] + _ -> return [ CmdClear ] + procMButton Released ButtonLeft _ = do + modify $ \s -> s { leftButtonDown = Nothing } + return [] + procMButton Pressed ButtonRight p = do + (pos@(mPos,_),_) <- getMousePosAt p + modify $ \s -> s { rightButtonDown = Just mPos } + lb <- gets (isJust . leftButtonDown) + if lb + then return [ CmdWait ] + else (fromMaybe [] <$>) $ runMaybeT $ msum + [ do + cmd <- MaybeT $ cmdAtMousePos pos mode Nothing + guard $ mode /= IMTextInput + -- modify $ \s -> s { settingBinding = Just cmd } + return [ CmdBind $ Just cmd ] + , do + cmd <- MaybeT $ cmdAtMousePos pos mode (Just True) + return [cmd] + , case mode of + IMPlay -> return [ CmdClear, CmdWait ] + _ -> return [ CmdClear, CmdSelect ] ] + procMButton Released ButtonRight _ = do + modify $ \s -> s { rightButtonDown = Nothing } + return [ CmdUnselect | mode == IMEdit ] + procMButton Pressed ButtonMiddle p = do + ((mPos,_),_) <- getMousePosAt p + modify $ \s -> s { middleButtonDown = Just mPos } + rb <- gets (isJust . rightButtonDown) + return $ [CmdDelete | rb] + procMButton Released ButtonMiddle _ = do + modify $ \s -> s { middleButtonDown = Nothing } + return [] + procMButton _ _ _ = pure [] + doWheel dw = do + rb <- gets (isJust . rightButtonDown) + mb <- gets (isJust . middleButtonDown) + if ((rb || mb || mode == IMReplay) && mode /= IMEdit) + || (mb && mode == IMEdit) + then return [ if dw == 1 then CmdRedo else CmdUndo ] + else if mode /= IMEdit || rb + then return [ CmdRotate WHSSelected dw ] + else do + modify $ \s -> s { paintTileIndex = (paintTileIndex s + dw) `mod` length paintTiles } + return [] + + + drawCmd mt True = CmdPaint mt + drawCmd (Just t) False = CmdTile t + drawCmd Nothing _ = CmdDelete + + getMousePosAt :: Integral i => Point V2 i -> UIM ((HexVec,Bool),(Double,Double,Double)) + getMousePosAt (P (V2 x y)) = do + (scrCentre, size) <- getGeom + let sv = SVec (fi x) (fi y) +^ neg scrCentre + let mPos@(HexVec x' y' z') = sVec2HexVec size sv + let (sx,sy,sz) = sVec2dHV size sv + let isCentral = all (\(a,b) -> abs (fi a - b) < 0.5) + [(x',sx),(y',sy),(z',sz)] + return ((mPos,isCentral),(sx,sy,sz)) + updateMousePos newPos = do + oldPos <- gets mousePos + when (newPos /= oldPos) $ do + modify $ \ds -> ds { mousePos = newPos } + updateHoverStr mode + + showHelp mode page = clearFrame >> showHelp' mode page + + onNewMode _ = clearMsg + + withNoBG m = do + bg <- gets bgTexture + modify $ \uiState -> uiState{bgTexture=Nothing} + m + isNothing <$> gets bgTexture >>? + modify (\uiState -> uiState{bgTexture=bg}) + +drawMainState' :: MainState -> MainStateT UIM () +drawMainState' PlayState { psCurrentState=st, psLastAlerts=alerts, + wrenchSelected=wsel, psTutLevel=tutLev, psSolved=solved } = do + canRedo <- gets (null . psUndoneStack) + let isTut = isJust tutLev + lift $ do + let selTools = [ idx | + (idx, PlacedPiece _ p) <- enumVec $ placedPieces st + , (wsel && isWrench p) || (not wsel && isHook p) ] + drawMainGameState selTools False alerts st + when isTut $ do + centre <- gets dispCentre + sequence_ + [ registerSelectable (pos -^ centre) 0 $ + case p of + Wrench v -> SelToolWrench $ v /= zero + _ -> SelToolHook + | PlacedPiece pos p <- Vector.toList $ placedPieces st + , isTool p] + unless (noUndoTutLevel tutLev) $ do + registerUndoButtons canRedo + registerButtonGroup markButtonGroup + registerButton (periphery 0) CmdOpen (if solved then 2 else 0) $ + ("open", hu+^neg hw) : [("Press-->",9*^neg hu) | solved && isTut] +drawMainState' ReplayState { rsCurrentState=st, rsLastAlerts=alerts } = do + canRedo <- gets (null . rsMoveStack) + lift $ do + drawMainGameState [] False alerts st + registerUndoButtons canRedo + renderToMain $ drawCursorAt Nothing +drawMainState' EditState { esGameState=st, esUndoneStack=undostack, + selectedPiece=selPiece, selectedPos=selPos } = lift $ do + drawMainGameState (maybeToList selPiece) True [] st + renderToMain $ drawCursorAt $ if isNothing selPiece then Just selPos else Nothing + registerUndoButtons (null undostack) + when (isJust selPiece) $ mapM_ registerButtonGroup + [ singleButton (periphery 2 +^ 3*^hw+^hv) CmdDelete 0 [("delete",hu+^neg hw)] + , singleButton (periphery 2 +^ 3*^hw) CmdMerge 1 [("merge",hu+^neg hw)] + ] + sequence_ + [ unless (any (p . placedPiece) . Vector.toList $ placedPieces st) + $ registerButton (periphery 0 +^ d) cmd 2 [("place",hu+^neg hw),(tool,hu+^neg hv)] + | (p,tool,cmd,d) <- [ + (isWrench, "wrench", CmdTile $ WrenchTile zero, (-4)*^hv +^ hw), + (isHook, "hook", CmdTile HookTile, (-3)*^hv +^ hw) ] ] + drawPaintButtons +drawMainState' InitState {initLocks=iLocks, tutProgress=TutProgress{tutSolved=tSolved}} = lift $ do + renderToMain $ do + erase + drawCursorAt Nothing + renderStrColAtCentre white "I N T R I C A C Y" $ 3 *^ (hv +^ neg hw) + unless tSolved $ renderStrColAtCentre (dim white) "Click TUT or press S to start" $ 2 *^ (hv +^ neg hw) + drawInitLock zero + mapM_ drawInitLock $ Map.keys accessible + registerButton (tutPos +^ 3 *^ neg hu +^ hv) (CmdSolveInit Nothing) 2 + [("solve",hu+^neg hw),("lock",hu+^neg hv)] + where + accessible = accessibleInitLocks tSolved iLocks + tutPos = maximumBound 0 (hx <$> Map.keys accessible) *^ neg hu + name v | v == zero = "TUT" + | otherwise = maybe "???" initLockName $ Map.lookup v accessible + solved v | v == zero = tSolved + | otherwise = Just True == (initLockSolved <$> Map.lookup v accessible) + isLast v | v == zero = False + | otherwise = Just True == (isLastInitLock <$> Map.lookup v accessible) + drawInitLock v = do + let pos = tutPos +^ 2 *^ v + drawNameCol (name v) pos $ if solved v then brightish green else brightish yellow + renderToMain $ sequence_ + [ (if open then PathGlyph h $ brightish white + else GateGlyph h $ bright white) + `drawAtRel` (pos +^ h) + | h <- hexDirs + , let v' = v +^ h + , let inbounds = abs (hy v') < 2 && hx v' >= 0 && hz v' <= 0 + , let acc = v' `Map.member` accessible || v' == zero + , not acc || h `elem` [hu, neg hw, neg hv] + , let open = inbounds && (solved v || solved v') && (acc || (isLast v && h == hu)) ] + registerSelectable pos 0 $ if v == zero then SelTut (solved v) else SelInitLock v (solved v) +drawMainState' MetaState {curServer=saddr, undeclareds=undecls, + cacheOnly=cOnly, curAuth=auth, codenameStack=names, + randomCodenames=rnamestvar, retiredLocks=mretired, curLockPath=path, + curLock=mlock, asyncCount=count} = do + modify $ \ms -> ms { listOffsetMax = True } + let ourName = authUser <$> auth + let selName = listToMaybe names + let home = isJust ourName && ourName == selName + lift $ renderToMain (erase >> drawCursorAt Nothing) + lift $ do + smallFont <- gets dispFontSmall + renderToMain $ withFont smallFont $ renderStrColAtLeft purple + (saddrStr saddr ++ if cOnly then " (offline mode)" else "") + $ serverPos +^ hu + + when (length names > 1) $ lift $ registerButton + (codenamePos +^ neg hu +^ 2*^hw) CmdBackCodename 0 [("back",3*^hw)] + + void . runMaybeT $ do + name <- MaybeT (return selName) + FetchedRecord isFresh err muirc <- lift $ getUInfoFetched 300 name + pending <- ((>0) <$>) $ liftIO $ readTVarIO count + lift $ do + lift $ do + unless ((isFresh && not pending) || cOnly) $ do + smallFont <- gets dispFontSmall + let str = if pending then "(response pending)" else "(updating)" + renderToMain $ withFont smallFont $ + renderStrColBelow (opaquify $ dim errorCol) str codenamePos + maybe (return ()) (setMsgLineNoRefresh errorCol) err + when (isFresh && (isNothing ourName || isNothing muirc || home)) $ + let reg = isNothing muirc || isJust ourName + in registerButton (codenamePos +^ 2*^hu) + (if reg then CmdRegister else CmdAuth) + (if isNothing ourName then 2 else 0) + [(if reg then "reg" else "auth", 3*^hw)] + (if isJust muirc then drawName else drawNullName) name codenamePos + lift $ registerSelectable codenamePos 0 (SelSelectedCodeName name) + drawRelScore name (codenamePos+^hu) + when (isJust muirc) $ lift $ + registerButton retiredPos CmdShowRetired 5 [("retired",hu+^neg hw)] + for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of + Just retired -> do + fillArea locksPos + (map (locksPos+^) $ zero:[rotate n $ 4*^hu-^4*^hw | n <- [0,2,3,5]]) + [ \pos -> lift (registerSelectable pos 1 (SelOldLock ls)) >> drawOldLock ls pos + | ls <- retired ] + lift $ registerButton (retiredPos +^ hv) (CmdPlayLockSpec Nothing) 1 [("play",hu+^neg hw),("no.",hu+^neg hv)] + Nothing -> do + sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) mlockinfo | + (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)] + when (isJust ourName) $ + registerButton (interactButtonsPos+^hw) (CmdViewSolution Nothing) 1 [("view",hu+^neg hw),("soln",hu+^neg hv)] + + when home $ do + lift.renderToMain $ renderStrColAt messageCol + "Home" (codenamePos+^hw+^neg hv) + unless (null undecls) $ do + lift.renderToMain $ renderStrColAtLeft messageCol "Undeclared:" (undeclsPos+^2*^hv+^neg hu) + lift $ registerButton (undeclsPos+^hw+^neg hu) (CmdDeclare Nothing) 2 [("decl",hv+^4*^neg hu),("soln",hw+^4*^neg hu)] + fillArea (undeclsPos+^hv) + (map (undeclsPos+^) $ hexDisc 1 ++ [hu+^neg hw, neg hu+^hv]) + [ \pos -> lift (registerSelectable pos 0 (SelUndeclared undecl)) >> drawActiveLock al pos + | undecl@(Undeclared _ _ al) <- undecls ] + let tested = maybe False (isJust.snd) mlock + when (isJust mlock && home) $ lift $ registerButton + (miniLockPos+^2*^neg hw+^3*^hu) (CmdPlaceLock Nothing) + (if tested then 2 else 1) + [("place",hu+^neg hw),("lock",hu+^neg hv)] + + when (home || (isNothing ourName && not (null path))) . lift $ do + maybe + (drawEmptyMiniLock miniLockPos) + ((`drawMiniLock` miniLockPos) <$> fst) mlock + registerSelectable miniLockPos 1 SelOurLock + registerButton (miniLockPos+^3*^neg hw+^2*^hu) CmdEdit 2 + [("edit",hu+^neg hw),("lock",hu+^neg hv)] + registerButton lockLinePos CmdSelectLock 1 $ + if null path then [ ("select",hu+^neg hw), ("lock",hu+^neg hv) ] else [] + unless (null path) $ do + renderToMain $ renderStrColAtLeft messageCol (take 16 path) $ lockLinePos +^ hu + registerSelectable (lockLinePos +^ 2*^hu) 1 SelLockPath + sequence_ + [ registerButton (miniLockPos +^ 2*^neg hv +^ 2*^hu +^ dv) cmd 1 + [(dirText,hu+^neg hw),("lock",hu+^neg hv)] + | (dv,cmd,dirText) <- [(zero,CmdPrevLock,"prev"),(neg hw,CmdNextLock,"next")] ] + when (isJust mlock) $ + registerButton (miniLockPos +^ neg hv +^ 6 *^ hu) CmdDeleteLock 0 + [("delete",hu+^neg hw),("lock",hu+^neg hv)] + + rnames <- liftIO $ readTVarIO rnamestvar + unless (null rnames) $ + fillArea randomNamesPos + (map (randomNamesPos+^) $ hexDisc 2) + [ \pos -> lift (registerSelectable pos 0 (SelRandom name)) >> drawName name pos + | name <- rnames ] + + when (ourName /= selName) $ void $ runMaybeT $ do + when (isJust ourName) $ + lift.lift $ registerButton (codenamePos +^ hw +^ neg hv) CmdHome 1 [("home",3*^hw)] + sel <- liftMaybe selName + us <- liftMaybe ourName + ourUInfo <- mgetUInfo us + selUInfo <- mgetUInfo sel + let accesses = map (uncurry getAccessInfo) [(ourUInfo,sel),(selUInfo,us)] + let posLeft = scoresPos +^ hw +^ neg hu + let posRight = posLeft +^ 3*^hu + lift $ do + lift.renderToMain $ renderStrColAbove (brightish white) "ESTEEM" scoresPos + lift $ sequence_ [ registerSelectable (scoresPos+^v) 0 SelRelScore | v <- [hv, hv+^hu] ] + drawRelScore sel scoresPos + fillArea (posLeft+^hw) (map (posLeft+^) [zero,hw,neg hv]) + [ \pos -> do + lift $ registerSelectable pos 0 (SelScoreLock (Just sel) accessed $ ActiveLock us i) + drawNameWithCharAndCol us white (lockIndexChar i) col pos + lift $ drawRelScoreGlyph pos relScore + | i <- [0..2] + , let accessed = head accesses !! i + , let (col, relScore) + | accessed == Just AccessedPub = (dim pubColour, Just $ -1) + | isJust accessed = (dim $ scoreColour $ -3, Just $ -1) + | otherwise = (obscure $ scoreColour 3, Nothing) ] + fillArea (posRight+^hw) (map (posRight+^) [zero,hw,neg hv]) + [ \pos -> do + lift $ registerSelectable pos 0 (SelScoreLock Nothing accessed $ ActiveLock sel i) + drawNameWithCharAndCol sel white (lockIndexChar i) col pos + lift $ drawRelScoreGlyph pos relScore + | i <- [0..2] + , let accessed = accesses !! 1 !! i + , let (col, relScore) + | accessed == Just AccessedPub = (dim pubColour, Just 1) + | isJust accessed = (dim $ scoreColour 3, Just 1) + | otherwise = (obscure $ scoreColour $ -3, Nothing) ] + (posScore,negScore) <- MaybeT $ (snd<$>) <$> getRelScoreDetails sel + let (shownPosScore, shownNegScore) = (3 - negScore, 3 - posScore) + lift.lift $ sequence_ + [ do + renderToMain $ renderStrColAt (scoreColour score) (sign:show (abs score)) pos + registerSelectable pos 0 SelRelScoreComponent + | (sign,score,pos) <- + [ ('-',-shownNegScore,posLeft+^neg hv+^hw) + , ('+',shownPosScore,posRight+^neg hv+^hw) ] ] + + +drawShortMouseHelp mode s = do + mh <- gets $ Map.notMember mode . whsButtons . uiOptions + showBT <- gets (showButtonText . uiOptions) + when (showBT && mh) $ do + let helps = shortMouseHelp mode s + smallFont <- gets dispFontSmall + renderToMain $ withFont smallFont $ sequence_ + [ renderStrColAtLeft (dim white) help + (periphery 3 +^ neg hu +^ (2-n)*^hv ) + | (n,help) <- zip [0..] helps ] + where + shortMouseHelp IMPlay PlayState { psTutLevel = tutLev } = + [ "LMB: select/move tool" + , "LMB+drag: move tool" ] ++ + [ "Wheel: turn hook" + | not $ wrenchOnlyTutLevel tutLev ] ++ + [ "RMB+Wheel: undo/redo" + | not $ noUndoTutLevel tutLev ] ++ + [ "RMB: wait a turn" + | isNothing tutLev ] + shortMouseHelp IMEdit _ = + [ "LMB: paint; Ctrl+LMB: delete" + , "Wheel: set paint type" + , "RMB: select piece; drag to move" + , "RMB+Wheel: tighten/loosen spring, rotate piece" + , "RMB+LMB: wait; RMB+MMB: delete piece" + , "MMB+Wheel: undo/redo" + ] + shortMouseHelp IMReplay _ = + [ "Wheel: advance/regress time" ] + shortMouseHelp _ _ = [] + +-- waitEvent' : copy of SDL.Events.waitEvent, with the timeout increased +-- drastically to reduce CPU load when idling. +waitEvent' :: IO Event +waitEvent' = loop + where loop = do pumpEvents + maybe (threadDelay 30000 >> loop) pure =<< pollEvent + +getEvents = do + e <- waitEvent' + es <- pollEvents + return $ e:es + +getEventsTimeout :: Int -> IO [Event] +getEventsTimeout us = do + es <- maybeToList <$> timeout us waitEvent' + es' <- pollEvents + return $ es++es' + +updateHoverStr :: InputMode -> UIM () +updateHoverStr mode = do + p@(mPos,_) <- gets mousePos + showBT <- gets (showButtonText . uiOptions) + hstr <- runMaybeT $ msum + [ MaybeT ( cmdAtMousePos p mode Nothing ) >>= lift . describeCommandAndKeys + , guard showBT >> MaybeT (helpAtMousePos p mode) + , guard (showBT && mode == IMEdit) >> msum + [ return $ "set paint mode: " ++ describeCommand (paintTileCmds!!i) + | i <- take (length paintTiles) [0..] + , mPos == paintButtonStart +^ i*^hv ] + , guard (mPos == uiOptPos uiOB1 && mode `elem` uiOptModes uiOB1) >> describeUIOptionButton uiOB1 + , guard (mPos == uiOptPos uiOB2 && mode `elem` uiOptModes uiOB2) >> describeUIOptionButton uiOB2 + , guard (mPos == uiOptPos uiOB3P && mode `elem` uiOptModes uiOB3P) >> describeUIOptionButton uiOB3P + , guard (mPos == uiOptPos uiOB3E && mode `elem` uiOptModes uiOB3E) >> describeUIOptionButton uiOB3E + , guard (mPos == uiOptPos uiOB4 && mode `elem` uiOptModes uiOB4) >> describeUIOptionButton uiOB4 + , guard (mPos == uiOptPos uiOB5 && mode `elem` uiOptModes uiOB5) >> describeUIOptionButton uiOB5 +#ifdef SOUND + , guard (mPos == uiOptPos uiOB6 && mode `elem` uiOptModes uiOB6) >> describeUIOptionButton uiOB6 +#endif + ] + modify $ \ds -> ds { hoverStr = hstr } + where + describeCommandAndKeys :: Command -> UIM String + describeCommandAndKeys cmd = do + uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings) + let [uiKeys, defKeys] = (\bdgs -> unwords $ showKeyFriendly <$> findBindings bdgs cmd) + <$> [uibdgs, bindings mode] + return $ describeCommand cmd + ++ " [" + ++ (if null uiKeys then "keys: " else "user keys: " <> uiKeys <> " defaults: ") + ++ defKeys + ++ "]" + + +fillArea :: HexVec -> [HexVec] -> [HexVec -> MainStateT UIM ()] -> MainStateT UIM () +fillArea centre area draws = do + offset <- gets listOffset + let na = length area + listButton cmd pos = lift $ registerButton pos cmd 3 [] + draws' = if offset > 0 && length draws > na + then listButton CmdPrevPage : + drop (max 0 $ na-1 + (na-2)*(offset-1)) draws + else draws + (selDraws,allDrawn) = if length draws' > na + then (take (na-1) draws' ++ [listButton CmdNextPage], False) + else (take na draws', True) + unless allDrawn . modify $ \ms -> ms { listOffsetMax = False } + mapM_ (uncurry ($)) ( + zip selDraws $ sortBy (compare `on` hexVec2SVec 37) $ + take (length selDraws) $ sortBy + (compare `on` (hexLen . (-^centre))) + area) + +drawOldLock ls pos = void.runMaybeT $ msum [ do + lock <- mgetLock ls + lift.lift $ drawMiniLock lock pos + , lift.lift.renderToMain $ + renderStrColAt messageCol (show ls) pos + ] + + +drawName,drawNullName :: Codename -> HexVec -> MainStateT UIM () +drawName name pos = do + lift . drawNameCol name pos =<< nameCol name + lift . drawRelScoreGlyph pos =<< getRelScore name +drawNullName name pos = lift . drawNameCol name pos $ invisible white + +drawNameCol name pos col = renderToMain $ do + drawAtRel (playerGlyph col) pos + renderStrColAt buttonTextCol name pos + +drawRelScoreGlyph _ Nothing = return () +drawRelScoreGlyph pos relScore = renderToMain . (`drawAtRel` pos) $ ScoreGlyph relScore + +drawRelScore name pos = do + col <- nameCol name + relScore <- getRelScore name + flip (maybe (return ())) relScore $ \score -> + lift $ do + renderToMain $ renderStrColAt col + ((if score > 0 then "+" else "") ++ show score) pos + registerSelectable pos 0 SelRelScore + +drawNote note pos = case noteBehind note of + Just al -> drawActiveLock al pos + Nothing -> drawPublicNote (noteAuthor note) pos +drawActiveLock al@(ActiveLock name i) pos = do + accessed <- accessedAL al + drawNameWithChar name + (if accessed then accColour else white) + (lockIndexChar i) pos +drawPublicNote name = drawNameWithChar name pubColour 'P' +drawNameWithChar name charcol char pos = do + col <- nameCol name + drawNameWithCharAndCol name charcol char col pos + lift . drawRelScoreGlyph pos =<< getRelScore name +drawNameWithCharAndCol :: String -> Color -> Char -> Color -> HexVec -> MainStateT UIM () +drawNameWithCharAndCol name charcol char col pos = do + let up = FVec 0 $ 1/2 - ylen + let down = FVec 0 ylen + smallFont <- lift $ gets dispFontSmall + lift.renderToMain $ do + drawAtRel (playerGlyph col) pos + displaceRender up $ + renderStrColAt buttonTextCol name pos + displaceRender down $ withFont smallFont $ + renderStrColAt charcol [char] pos +pubWheelAngle = 5 +pubColour = colourWheel pubWheelAngle -- ==purple +accColour = cyan +nameCol name = do + ourName <- gets ((authUser <$>) . curAuth) + relScore <- getRelScore name + return $ dim $ case relScore of + Nothing -> if ourName == Just name then V4 0xc0 0xc0 0 0 else V4 0x80 0x80 0 0 + Just score -> scoreColour score +scoreColour :: Int -> Color +scoreColour score = case score of + 0 -> V4 0x80 0x80 0 0 + 1 -> V4 0x70 0xa0 0 0 + 2 -> V4 0x40 0xc0 0 0 + 3 -> V4 0x00 0xff 0 0 + (-1) -> V4 0xa0 0x70 0 0 + (-2) -> V4 0xc0 0x40 0 0 + (-3) -> V4 0xff 0x00 0 0 + _ -> error $ "Bad score for scoreColour" <> show score + +drawLockInfo :: ActiveLock -> Maybe LockInfo -> MainStateT UIM () +drawLockInfo al@(ActiveLock name idx) Nothing = do + let centre = hw+^neg hv +^ 7*(idx-1)*^hu + lift $ drawEmptyMiniLock centre + drawNameWithCharAndCol name white (lockIndexChar idx) (invisible white) centre + ourName <- gets ((authUser <$>) . curAuth) + lift $ registerSelectable centre 3 $ SelLockUnset (ourName == Just name) al +drawLockInfo al@(ActiveLock name idx) (Just lockinfo) = do + let centre = locksPos +^ 7*(idx-1)*^hu + let accessedByPos = centre +^ 3*^(hv +^ neg hw) + let accessedPos = centre +^ 2*^(hw +^ neg hv) + let notesPos = centre +^ 3*^(hw +^ neg hv) + ourName <- gets ((authUser <$>) . curAuth) + void . runMaybeT $ msum [ + do + lock <- mgetLock $ lockSpec lockinfo + lift.lift $ do + drawMiniLock lock centre + registerSelectable centre 3 $ SelLock al + , lift $ do + drawActiveLock al centre + lift $ registerSelectable centre 3 $ SelLock al + ] + + lift $ do + renderToMain $ displaceRender (FVec 1 0) $ renderStrColAt (brightish white) "SOLUTIONS" $ accessedByPos +^ hv + registerSelectable (accessedByPos +^ hv) 0 SelPrivyHeader + registerSelectable (accessedByPos +^ hv +^ hu) 0 SelPrivyHeader + if public lockinfo + then lift $ do + renderToMain $ renderStrColAt pubColour "Public" accessedByPos + registerSelectable accessedByPos 1 SelPublicLock + else if null $ accessedBy lockinfo + then lift.renderToMain $ renderStrColAt dimWhiteCol "None" accessedByPos + else fillArea accessedByPos + [ accessedByPos +^ d | j <- [0..2], i <- [-2..3] + , i-j > -4, i-j < 3 + , let d = j*^hw +^ i*^hu ] + $ [ \pos -> lift (registerSelectable pos 0 (SelSolution note)) >> drawNote note pos + | note <- lockSolutions lockinfo ] + + undecls <- gets undeclareds + case if isJust $ guard . (|| public lockinfo) . (`elem` map noteAuthor (lockSolutions lockinfo)) =<< ourName + then if public lockinfo + then Just (pubColour,"Accessed!",AccessedPublic) + else Just (accColour, "Solved!",AccessedSolved) + else if any (\(Undeclared _ ls _) -> ls == lockSpec lockinfo) undecls + then Just (yellow, "Undeclared",AccessedUndeclared) + else Nothing + of + Just (col,str,selstr) -> lift $ do + renderToMain $ renderStrColAt col str accessedPos + registerSelectable accessedPos 1 (SelAccessedInfo selstr) + Nothing -> do + readNotes <- take 3 <$> getNotesReadOn lockinfo + unless (ourName == Just name) $ do + let readPos = accessedPos +^ (-3)*^hu + lift.renderToMain $ renderStrColAt (if length readNotes == 3 then accColour else dimWhiteCol) + "Read:" readPos + when (length readNotes == 3) $ lift $ registerSelectable readPos 0 (SelAccessedInfo AccessedReadNotes) + fillArea (accessedPos+^neg hu) [ accessedPos +^ i*^hu | i <- [-1..1] ] + $ take 3 $ [ \pos -> lift (registerSelectable pos 0 (SelReadNote note)) >> drawNote note pos + | note <- readNotes ] ++ repeat (\pos -> lift $ registerSelectable pos 0 SelReadNoteSlot >> + renderToMain (drawAtRel (HollowGlyph $ dim green) pos)) + + lift $ do + 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 + then lift.renderToMain $ renderStrColAt dimWhiteCol "None" notesPos + else fillArea notesPos + [ notesPos +^ d | j <- [0..2], i <- [-2..3] + , i-j > -4, i-j < 3 + , let d = j*^hw +^ i*^hu ] + [ \pos -> lift (registerSelectable pos 0 (SelSecured note)) >> drawActiveLock (noteOn note) pos + | note <- notesSecured lockinfo ] + +showHelp' mode HelpPageInput = do + bdgs <- nub <$> getBindings mode + smallFont <- gets dispFontSmall + renderToMain $ do + let extraHelpStrs = (["Mouse commands:", "Hover over a button to see keys, right-click to rebind;"] + ++ case mode of + IMPlay -> ["Click on tool to select, drag to move;", + "Click by tool to move; right-click to wait;", "Scroll wheel to rotate hook;", + "Scroll wheel with right button held down to undo/redo."] + IMEdit -> ["Left-click to draw selected; scroll to change selection;", + "Right-click on piece to select, drag to move;", + "While holding right-click: left-click to advance time, middle-click to delete;", + "Scroll wheel to rotate selected piece; scroll wheel while held down to undo/redo."] + IMReplay -> ["Scroll wheel for undo/redo."] + IMMeta -> ["Left-clicking on something does most obvious thing;" + , "Right-clicking does second-most obvious thing."] + _ -> []) + : case mode of + IMMeta -> [[ + "Basic game instructions:" + , "Choose [C]odename, then [R]egister it;" + , "select other players, and [S]olve their locks;" + , "go [H]ome, then [E]dit and [P]lace a lock of your own;" + , "you can then [D]eclare your solutions." + , "Make other players green by solving their locks and not letting them solve yours."]] + _ -> [] + when False $ do + renderStrColAtCentre cyan "Keybindings:" $ (screenHeightHexes`div`4)*^(hv+^neg hw) + let keybindingsHeight = screenHeightHexes - fi (3 + length extraHelpStrs + sum (map length extraHelpStrs)) + bdgWidth = (screenWidthHexes-6) `div` 3 + showKeys chs = intercalate "/" (map showKeyFriendly chs) + sequence_ [ with $ renderStrColAtLeft messageCol + ( keysStr ++ ": " ++ desc ) + $ (x*bdgWidth-(screenWidthHexes-6)`div`2)*^hu +^ neg hv +^ + (screenHeightHexes`div`4 - y`div`2)*^(hv+^neg hw) +^ + (y`mod`2)*^hw + | ((keysStr,with,desc),(x,y)) <- zip [(keysStr,with,desc) + | grp <- groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs + , let cmd = snd $ head grp + , let desc = describeCommand cmd + , not $ null desc + , let chs = map fst grp + , let keysStr = showKeys chs + , let with = if True -- 3*(bdgWidth-1) < length desc + length keysStr + 1 + then withFont smallFont + else id + ] + (map (`divMod` keybindingsHeight) [0..]) + , (x+1)*bdgWidth < screenWidthHexes] + sequence_ [ renderStrColAtCentre (if firstLine then cyan else messageCol) str + $ (screenHeightHexes`div`4 - y`div`2)*^(hv+^neg hw) + +^ hw + +^ (y`mod`2)*^hw + | ((str,firstLine),y) <- intercalate [("",False)] (map (`zip` + (True:repeat False)) extraHelpStrs) `zip` + --[(keybindingsHeight+1)..] + [((screenHeightHexes - sum (fi . length <$> extraHelpStrs)) `div` 2)..] + ] + return True +showHelp' IMInit HelpPageGame = do + renderToMain $ drawBasicHelpPage ("INTRICACY",red) (initiationHelpText,purple) + return True +showHelp' IMMeta HelpPageGame = do + renderToMain $ drawBasicHelpPage ("INTRICACY",red) (metagameHelpText,purple) + return True +showHelp' IMMeta (HelpPageInitiated n) = do + renderToMain $ drawBasicHelpPage ("Initiation complete",purple) (initiationCompleteText n,red) + return True +showHelp' IMEdit HelpPageFirstEdit = do + renderToMain $ drawBasicHelpPage ("Your first lock:",purple) (firstEditHelpText,green) + return True +showHelp' _ _ = return False + +drawBasicHelpPage :: (String,Color) -> ([String],Color) -> RenderM () +drawBasicHelpPage (title,titleCol) (body,bodyCol) = do + let startPos = hv +^ (length body `div` 4)*^(hv+^neg hw) + renderStrColAtCentre titleCol title $ startPos +^ hv +^neg hw + sequence_ + [ renderStrColAtCentre bodyCol str $ + startPos + +^ (y`div`2)*^(hw+^neg hv) + +^ (y`mod`2)*^hw + | (y,str) <- zip [0..] body ] diff --git a/SDLGlyph.hs b/SDLGlyph.hs --- a/SDLGlyph.hs +++ b/SDLGlyph.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 diff --git a/SDLRender.hs b/SDLRender.hs --- a/SDLRender.hs +++ b/SDLRender.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 diff --git a/SDLUI.hs b/SDLUI.hs --- a/SDLUI.hs +++ b/SDLUI.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -8,16 +8,17 @@ -- 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 CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} module SDLUI where import Control.Applicative import Control.Arrow import Control.Concurrent.STM -import Control.Monad ((<=<)) +import Control.Monad import Control.Monad.State import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader @@ -785,7 +786,7 @@ fs <- gets (fullscreen . uiOptions) liftIO $ do (w',h') <- if fs || (w,h)/=(0,0) then return (w,h) else -#ifdef APPLE +#ifdef APPLE_SDL1 -- use smaller dimensions than the screen's, to work around a bug -- seen on mac, whereby a resizable window created with -- (w,h)=(0,0), or even with the (w,h) given by getHardwareDimensions @@ -911,7 +912,7 @@ miniLockPos = (-9)*^hw +^ hu lockLinePos = 4*^hu +^ miniLockPos serverPos = 12*^hv +^ 7*^neg hu -serverWaitPos = serverPos +^ hw +^ neg hu +serverWaitPos = serverPos +^ hw +^ hu randomNamesPos = 9*^hv +^ 2*^ neg hu codenamePos = (-6)*^hw +^ 6*^hv undeclsPos = 13*^neg hu diff --git a/SDLUIMInstance.hs b/SDLUIMInstance.hs --- a/SDLUIMInstance.hs +++ b/SDLUIMInstance.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -16,6 +16,7 @@ import Control.Applicative import Control.Concurrent (threadDelay) import Control.Concurrent.STM +import Control.Monad import Control.Monad.State import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader @@ -76,6 +77,7 @@ drawError = sayError reportAlerts = playAlertSounds + onPhysicsTick = pure () getChRaw = resetMouseButtons >> getChRaw' where @@ -555,7 +557,7 @@ when (fresh && (isNothing ourName || isNothing muirc || home)) $ let reg = isNothing muirc || isJust ourName in registerButton (codenamePos +^ 2*^hu) - (if reg then CmdRegister $ isJust ourName else CmdAuth) + (if reg then CmdRegister else CmdAuth) (if isNothing ourName then 2 else 0) [(if reg then "reg" else "auth", 3*^hw)] (if isJust muirc then drawName else drawNullName) name codenamePos diff --git a/Server.hs b/Server.hs --- a/Server.hs +++ b/Server.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -31,6 +31,7 @@ import qualified Data.Binary as B import qualified Data.ByteString.Char8 as CS import qualified Data.ByteString.Lazy as BL +import Data.Either (fromRight) import Data.Foldable (for_) import Data.Function (on) import Data.List @@ -83,7 +84,7 @@ defaultPort = 27001 -- 27001 == ('i'<<8) + 'y' -data Opt = RequestDelay Int | Daemon | LogFile FilePath | Port Int | DBDir FilePath | ServerLockSize Int | FeedPath FilePath | Help | Version +data Opt = RequestDelay Int | Daemon | LogFile FilePath | Port Int | DBDir FilePath | ServerLockSize Int | FeedPath FilePath | Rewrite | CheckNotes | Help | Version deriving (Eq, Ord, Show) options = [ Option ['p'] ["port"] (ReqArg (Port . read) "PORT") $ "TCP port to listen on (default: " ++ show defaultPort ++ ")" @@ -91,6 +92,8 @@ -- , Option ['d'] ["daemon"] (NoArg Daemon) "Run as daemon" , Option ['l'] ["logfile"] (ReqArg LogFile "PATH") "Log to file" , Option ['d'] ["dir"] (ReqArg DBDir "PATH") "directory for server database [default: intricacydb]" + , Option ['r'] ["refresh"] (NoArg Rewrite) "rewrite database (to convert from legacy formats)" + , Option ['c'] ["check-notes"] (NoArg CheckNotes) "confirm solutions in notes (in case of rule changes)" , Option ['s'] ["locksize"] (ReqArg (ServerLockSize . read) "SIZE") "size of locks (only takes effect when creating a new database) [default: 8]" , Option ['f'] ["feed"] (ReqArg FeedPath "PATH") "write news feed to this path" , Option ['h'] ["help"] (NoArg Help) "show usage information" @@ -128,6 +131,8 @@ logh <- case listToMaybe [ f | LogFile f <- opts ] of Nothing -> return stdout Just path -> openFile path AppendMode + when (Rewrite `elem` opts) $ rewriteDB dbpath logh + when (CheckNotes `elem` opts) $ checkNotes dbpath logh streamServer serverSpec{address = IPv4 "" port, threading=Threaded} $ handler dbpath delay logh mfeedPath sleepForever @@ -273,6 +278,13 @@ Nothing -> unless (checkSolution lock soln) $ throwE "Bad solution" Just lock' -> unless (lock == lock') $ throwE "Lock changed!" return $ Just lock + RetireLock target -> do + tinfo <- getALock target + name <- codename <$> getUserInfoOfAuth auth + RCIsSuperuser isSuper <- lift . (fromRight (RCIsSuperuser False) <$>) . runExceptT $ getRecordErrored (RecIsSuperuser name) + when (not isSuper && name /= lockOwner target) $ throwE "That isn't your lock!" + when (public tinfo) $ throwE "Lock already public." + pure Nothing _ -> return Nothing handleRequest' = case action of @@ -355,7 +367,7 @@ return ServerAck GetRandomNames n -> do names <- erroredDB listUsers - gen <- erroredIO getStdGen + gen <- erroredIO newStdGen let l = length names namesArray = listArray (0,l-1) names negligible name = do @@ -371,6 +383,10 @@ >-> P.take n -- try to take as many as we were asked for liftIO newStdGen return $ ServedRandomNames shuffled + RetireLock target -> do + lockInfo <- getALock target + execStateT (publiciseLock target lockInfo) [] >>= applyDeltasToRecords + return ServerAck _ -> throwE "BUG: bad request" erroredIO :: IO a -> ExceptT String IO a erroredIO c = do @@ -578,10 +594,41 @@ [plainPart $ TL.pack $ "A solution to your lock " ++ alockStr target ++ " has been declared by " ++ solverName ++ " and secured behind " ++ alockStr behind ++ "." ++ "\n\n-----\n\nYou received this email from the game Intricacy" ++ - "\n\thttp://sdf.org/~mbays/intricacy ." ++ + "\n\thttp://mbays.sdf.org/intricacy ." ++ "\nYou can disable notifications in-game by pressing 'R' on your home" ++ "\nscreen and setting an empty address." ++ "\nAlternatively, just reply to this email with the phrase \"stop bugging me\"." ] #else mailDeclaration _ _ = pure () #endif + +rewriteDB :: FilePath -> Handle -> IO () +rewriteDB dbpath logh = do + logit logh "Rewriting DB" + withDBLock dbpath WriteMode $ withDB dbpath $ do + users <- listUsers + forM_ users $ \name -> modifyRecord (RecUserInfo name) id + forM_ users $ \name -> modifyRecord (RecUserInfoLog name) id + logit logh "DB rewriting complete" + +checkNotes :: FilePath -> Handle -> IO () +checkNotes dbpath logh = do + logit logh "Checking notes" + withDBLock dbpath WriteMode $ withDB dbpath $ do + users <- listUsers + forM_ users $ \name -> do + RCUserInfo (_,uinfo) <- getRecordUnsafe $ RecUserInfo name + sequence_ [ do + RCSolution soln <- getRecordUnsafe $ RecNote note + RCLock lock <- getRecordUnsafe $ RecLock ls + unless (checkSolution lock soln) $ + liftIO . putStrLn $ "Bad note on " <> show name <> ":" <> [lockIndexChar idx] + | idx <- [0,1,2] + , Just lockinfo <- [userLocks uinfo ! idx] + , let ls = lockSpec lockinfo + , note <- lockSolutions lockinfo + ] + logit logh "Finished checking notes" + where + getRecordUnsafe :: Record -> DBM RecordContents + getRecordUnsafe = (fromJust <$>) . getRecord diff --git a/ServerAddr.hs b/ServerAddr.hs --- a/ServerAddr.hs +++ b/ServerAddr.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -36,5 +36,4 @@ Nothing -> Just $ ServerAddr str defaultPort Just idx -> do let (addr,portstr) = splitAt idx str - port <- fst <$> listToMaybe (reads (drop 1 portstr)) - return $ ServerAddr addr port + ServerAddr addr . fst <$> listToMaybe (reads (drop 1 portstr)) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 diff --git a/SimpleCache.hs b/SimpleCache.hs new file mode 100644 --- /dev/null +++ b/SimpleCache.hs @@ -0,0 +1,42 @@ +-- This file is part of Intricacy +-- Copyright (C) 2013-2025 Martin Bays +-- +-- 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 SimpleCache where + +import qualified Data.List as L +import qualified Data.Map as M + +-- Stupid implementation of least-recent caching +data SimpleCache k v = SimpleCache + { maxSize :: Int + , size :: Int + , cache :: M.Map k v + , order :: [k] + , dealloc :: v -> IO () + } + +empty :: Int -> (v -> IO ()) -> SimpleCache k v +empty mx = SimpleCache mx 0 M.empty [] + +insert :: (Eq k, Ord k) => k -> v -> SimpleCache k v -> IO (SimpleCache k v) +insert k v (SimpleCache mxSz sz c ks m) + | k `M.member` c = pure $ SimpleCache mxSz sz c (k:L.delete k ks) m + | sz < mxSz = pure $ SimpleCache mxSz (sz+1) (M.insert k v c) (k:ks) m + | mn <- last ks + , Just mnv <- c M.!? mn = do + m mnv + insert k v $ SimpleCache mxSz (sz-1) (M.delete mn c) (L.delete mn ks) m + | otherwise = error "BUG in SimpleCache.insert" + +deallocAll :: SimpleCache k v -> IO () +deallocAll (SimpleCache _ _ c _ m) = mapM_ m (M.elems c) + +(!?) :: (Eq k, Ord k) => SimpleCache k v -> k -> Maybe v +SimpleCache _ _ c _ _ !? k = c M.!? k diff --git a/Util.hs b/Util.hs --- a/Util.hs +++ b/Util.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 diff --git a/Version.hs b/Version.hs --- a/Version.hs +++ b/Version.hs @@ -1,5 +1,5 @@ -- This file is part of Intricacy --- Copyright (C) 2013 Martin Bays +-- Copyright (C) 2013-2025 Martin Bays -- -- 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 @@ -8,7 +8,9 @@ -- 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 CPP #-} + module Version where version :: String -version = "0.8.2.1" +version = CURRENT_PACKAGE_VERSION diff --git a/initiation/EQU.lock b/initiation/EQU.lock new file mode 100644 --- /dev/null +++ b/initiation/EQU.lock @@ -0,0 +1,17 @@ + " " " " " " " " " + " # % # " " " " + " # % # " " + " # " O " { " " + " # 7 % " [ " " " # # " + " # 7 % % " [ " # " " + " 7 % % " " " % % # " " + " 7 % % % " " " % # # " +" % % % % # o - % # # # " + " % # C C % Z % S S # " + " Z O % % % " + " " Z % " +" * ' Z % " + " @ " % & & & & & % " + " " " % # C C % 7 % " + " % % % % % % 7 % " + " " " " " " " " " diff --git a/initiation/EQU.text b/initiation/EQU.text new file mode 100644 --- /dev/null +++ b/initiation/EQU.text @@ -0,0 +1,1 @@ +Force equilibrium diff --git a/initiation/ICE.text b/initiation/ICE.text --- a/initiation/ICE.text +++ b/initiation/ICE.text @@ -1,1 +1,1 @@ -Obligatory slippy-slidey ice world +Slippy-slidey diff --git a/initiation/JIT.lock b/initiation/JIT.lock new file mode 100644 --- /dev/null +++ b/initiation/JIT.lock @@ -0,0 +1,17 @@ + " " " " " " " " " + " ~ ~ ~ ~ ~ # # " " " " + " ~ ~ ~ ~ # # " " + " ~ ~ ~ ~ ~ # # " # " + " ~ ~ ~ $ " O # # # # # " + " ~ ~ ~ ~ ~ # # # 7 " " + " ~ ~ ~ ~ ~ 7 " " + " ~ ~ ~ ~ ~ O % D " " " " " +" ~ & & & & & & & & " + " ~ ~ ~ ~ # # # & " + " & " + " " & & & & & & " +" * ' & C C C C C C C C C C " + " @ " % % % % % % % % % % " + " " " % % % % % % % % " + " % % % % % % % % " + " " " " " " " " " diff --git a/initiation/JIT.text b/initiation/JIT.text new file mode 100644 --- /dev/null +++ b/initiation/JIT.text @@ -0,0 +1,1 @@ +Just in time diff --git a/initiation/KCK.lock b/initiation/KCK.lock new file mode 100644 --- /dev/null +++ b/initiation/KCK.lock @@ -0,0 +1,17 @@ + " " " " " " " " " + " % % % S S # " " " " + " % # % # # " " + " . o " % % # # " " + " % O " % # % % % # # # " + " " % % % " " + " & & s s " % % % % " " + " & # & ' " { % # % " +" & & . o # " " # % % % " + " \ ' O O ' # % % % " + " % o % " " " " o % # % " + " " % # / % % % " +" * ' % # c c c c c c % " + " @ " % % % # % % % % " + " " " % Z % % % % # % " + " Z % % % % " + " " " " " " " " " diff --git a/initiation/KCK.text b/initiation/KCK.text new file mode 100644 --- /dev/null +++ b/initiation/KCK.text @@ -0,0 +1,1 @@ +Be faster diff --git a/initiation/PKR.lock b/initiation/PKR.lock new file mode 100644 --- /dev/null +++ b/initiation/PKR.lock @@ -0,0 +1,17 @@ + " " " " " " " " " + " { % s s & " " " " + " [ ] % & " " + " & s s s s % ] % & " " + " & % ] ] & & & " + " 1 # C C C C % ] ) % O & " " + " 1 " " ) # & " " + " 7 # { % # # # " +" 7 # # % # " + " % % % # % [ " + " % \ ' % # % ( " + " " o - o - ( " +" * ' ` # % % # ( " + " @ " # # # # 7 # ( " + " " " # 7 # % % " + " 7 " + " " " " " " " " " diff --git a/initiation/PKR.text b/initiation/PKR.text new file mode 100644 --- /dev/null +++ b/initiation/PKR.text @@ -0,0 +1,1 @@ +Poker diff --git a/initiation/RAT.lock b/initiation/RAT.lock --- a/initiation/RAT.lock +++ b/initiation/RAT.lock @@ -2,8 +2,8 @@ " " " " " " # " " " # # " # " - " # # # " - " # # % O O O " " " # " " + " # # # # " + " # # # % O O O " " " # " " " # % % O O O " " " # " " " % S S S S S S " # " " # # # # % % % % % " # # " diff --git a/initiation/REP.lock b/initiation/REP.lock --- a/initiation/REP.lock +++ b/initiation/REP.lock @@ -1,17 +1,17 @@ " " " " " " " " " " } " " " " " & } # S S % " " - " # & } & & % % " " - " 9 " & } & % % % " - " % 9 # & } & " " - " % 9 " & } & " " + " ~ & } & & % % " " + " 9 # & } & % % % " + " % 9 " & } & " " + " % 9 ~ & } & " " " % 9 # & & o " " % 9 \ ' O / ` # " " % o O # # " " % % S # / O # " " " % # O # " -" * ' % O # " +" * ' % % O # " " @ " % % % % % O # " " " " % " - " # " + " % " " " " " " " " " " diff --git a/initiation/RUN.lock b/initiation/RUN.lock deleted file mode 100644 --- a/initiation/RUN.lock +++ /dev/null @@ -1,17 +0,0 @@ - " " " " " " " " " - " ~ ~ ~ ~ ~ # # " " " " - " ~ ~ ~ ~ # # " " - " ~ ~ ~ ~ ~ # # " # " - " ~ ~ ~ $ " O # # # # # " - " ~ ~ ~ ~ ~ # # # 7 " " - " ~ ~ ~ ~ ~ 7 " " - " ~ ~ ~ ~ ~ O % D " " " " " -" ~ & & & & & & & & " - " ~ ~ ~ ~ # # # & " - " & " - " " & & & & & & " -" * ' & C C C C C C C C C C " - " @ " % % % % % % % % % % " - " " " % % % % % % % % " - " % % % % % % % % " - " " " " " " " " " diff --git a/initiation/RUN.text b/initiation/RUN.text deleted file mode 100644 --- a/initiation/RUN.text +++ /dev/null @@ -1,1 +0,0 @@ -Quick! diff --git a/initiation/initiation.map b/initiation/initiation.map --- a/initiation/initiation.map +++ b/initiation/initiation.map @@ -1,3 +1,3 @@ -[["DIV","ICE","CLR","COG","BAL"], -["RUN","HLD","SOK","ONE","END"], -["PLG","REP","CMB","GAP","RAT"]] +[["DIV","ICE","CLR","COG","KCK","BAL"], +["JIT","HLD","PKR","EQU","ONE","END"], +["PLG","REP","CMB","GAP","SOK","RAT"]] diff --git a/intricacy.cabal b/intricacy.cabal --- a/intricacy.cabal +++ b/intricacy.cabal @@ -1,7 +1,7 @@ -cabal-version: >=1.10 +cabal-version: 2.2 name: intricacy -version: 0.8.2.1 -license: GPL-3 +version: 0.9.0.0 +license: GPL-3.0-or-later license-file: COPYING maintainer: mbays@sdf.org author: Martin Bays @@ -30,9 +30,9 @@ initiation/*.lock initiation/*.text sounds/*.ogg - extra-source-files: Main_stub.h +extra-doc-files: README BUILD NEWS @@ -47,14 +47,24 @@ description: Build game manual: True -flag sdl - description: Enable SDL UI +flag sdl2 + description: Enable SDL2 UI +flag embed + description: Embed font into executable (with Template Haskell) when using sdl2 + flag sound description: Enable sound +flag sdl1 + description: Enable SDL1 UI (deprecated) + manual: True + default: False + flag curses - description: Enable Curses UI + description: Enable Curses UI (disables sdl2) + manual: True + default: False flag server description: Build server @@ -63,11 +73,11 @@ flag sendmail description: Include support for sending mail - default: False - manual: True executable intricacy main-is: Intricacy.hs + autogen-modules: + Paths_intricacy other-modules: AsciiLock BinaryInstances @@ -96,14 +106,14 @@ Physics Protocol ServerAddr + SimpleCache Util Version default-language: Haskell2010 - if !flag(game) + if !flag(game) || (!flag(sdl1) && !flag(sdl2) && !flag(curses)) buildable: False - else default-extensions: DoAndIfThenElse build-depends: @@ -114,31 +124,38 @@ directory >=1.0 && <1.4, exceptions >=0.8.3 && <0.11, filepath >=1.0 && <1.6, - time >=1.2 && <1.14, + time >=1.2 && <1.15, bytestring >=0.10 && <0.13, array >=0.3 && <0.6, - containers >=0.4 && <0.8, + containers >=0.4 && <0.9, vector >=0.9 && <0.14, binary >=0.5 && <0.11, network-simple >=0.3 && <0.5, safe >=0.3.18 && <0.4, memory >=0.11 && <0.19, - cryptonite >=0.16 && <0.31 + crypton <1.1, + text >=0.1 && <3 if !impl(ghc >=8.0) build-depends: semigroups ==0.18.* - if flag(sdl) + if flag(sdl1) build-depends: SDL >=0.6.5 && <0.7, SDL-ttf ==0.6.*, - SDL-gfx >=0.6 && <0.8 + SDL-gfx >=0.6 && <0.8, + random >=1.0 && <1.4 + cpp-options: -DMAIN_SDL1 + other-modules: + SDLGlyph + SDLRender + SDLUI + SDLUIMInstance if flag(sound) cpp-options: -DSOUND build-depends: - SDL-mixer ==0.6.*, - random >=1.0 && <1.4 + SDL-mixer ==0.6.* if os(windows) extra-libraries: @@ -146,42 +163,74 @@ SDL SDL_gfx freetype - ghc-options: -optl-mwindows - if flag(sound) extra-libraries: SDL_mixer if os(osx) - cpp-options: -DAPPLE + cpp-options: -DAPPLE_SDL1 c-sources: c_main.c include-dirs: /usr/include/SDL /usr/local/include/SDL ghc-options: -no-hs-main + if flag(sdl2) && !flag(sdl1) && !flag(curses) + -- compiling with curses causes sdl2 mode to crash; I'm not sure why. + build-depends: + sdl2 >=2.3 && <2.6, + sdl2-ttf >=2.0 && <2.3, + sdl2-gfx >=0.2 && <0.4, + random >=1.0 && <1.4 + cpp-options: -DMAIN_SDL2 + other-modules: + SDL2Glyph + SDL2Keys + SDL2Render + SDL2RenderCache + SDL2UI + SDL2UIMInstance + + if flag(sound) + cpp-options: -DSOUND + build-depends: + sdl2-mixer <1.3 + + if flag(embed) + cpp-options: -DEMBED + other-modules: + Font + build-depends: + file-embed <0.1 + + if os(windows) + extra-libraries: + SDL2_ttf + SDL2 + SDL2_gfx + freetype + ghc-options: -optl-mwindows + cpp-options: -DWINDOWS + if flag(sound) + extra-libraries: SDL2_mixer + + if os(osx) + cpp-options: -DAPPLE + c-sources: c_main.c + include-dirs: /usr/include/SDL2 /usr/local/include/SDL2 + ghc-options: -no-hs-main + if flag(curses) - cpp-options: -DMAIN_CURSES + cpp-options: -DMAIN_CURSES -DCURSES pkgconfig-depends: ncursesw -any other-modules: CursesRender CursesUI CursesUIMInstance - - build-depends: hscurses ==1.4.* - - if flag(sdl) - cpp-options: -DMAIN_SDL - other-modules: - SDLGlyph - SDLRender - SDLUI - SDLUIMInstance - - if (!flag(sdl) && !flag(curses)) - buildable: False - build-depends: base <0 + build-depends: hscurses <1.6 executable intricacy-server main-is: Server.hs + autogen-modules: + Paths_intricacy other-modules: AsciiLock BinaryInstances @@ -214,25 +263,25 @@ stm >=2.1 && <2.6, directory >=1.0 && <1.4, exceptions >=0.8.3 && <0.11, - filepath >=1.0 && <1.5, - time >=1.5 && <1.14, - bytestring >=0.10 && <0.12, + filepath >=1.0 && <1.6, + time >=1.5 && <1.15, + bytestring >=0.10 && <0.13, array >=0.3 && <0.6, - containers >=0.4 && <0.7, - vector >=0.9 && <0.13, + containers >=0.4 && <0.9, + vector >=0.9 && <0.14, binary >=0.5 && <0.11, network-fancy >=0.1.5 && <0.3, safe >=0.3.18 && <0.4, random >=1.0 && <1.4, pipes >=4 && <4.4, feed >=1.1 && <1.4, - xml-conduit >=1.0 && <1.10, + xml-conduit >=1.0 && <1.11, email-validate >=1.0 && <2.4, text >=0.1 && <3, text-short ==0.1.*, mime-mail >=0.4.4 && <0.6, - memory >=0.11 && <0.18, - cryptonite >=0.16 && <0.31, + memory >=0.11 && <0.19, + crypton <1.1, argon2 ==1.3.* if !impl(ghc >=8.0) @@ -241,6 +290,6 @@ if flag(sendmail) cpp-options: -DSENDMAIL build-depends: - smtp-mail >=0.1.4.1 && <0.4 + smtp-mail >=0.1.4.1 && <0.6 else buildable: False diff --git a/tutorial/03-time.lock b/tutorial/03-time.lock --- a/tutorial/03-time.lock +++ b/tutorial/03-time.lock @@ -1,15 +1,15 @@ - & & & & & & & & - & O & - & % % % % % % % & & & - & % & ~ & - & " c c c c c c c c # ~ & - & ] ~ ~ & & - & % ] ~ 1 & - & % % # % ' ~ 1 & - & % % o ~ # & - & & % % ` ~ # & -& * ' % % # & - & @ & % % % # & - & & & 5 # & - & # & - & & & & & & & & + " " " " " " " " + " O " + " # # # # # # # " " " + " # " & " + " % c c c c c c c c # & " + " ] & & " " + " # ] & 1 % " + " # # " # ' & 1 % " + " # # o & 1 % " + " " # # ` & 1 % " +" * ' # # % % " + " @ " # # # % % " + " " " # % % " + " 5 % " + " " " " " " " " diff --git a/tutorial/08-traps.text b/tutorial/08-traps.text --- a/tutorial/08-traps.text +++ b/tutorial/08-traps.text @@ -1,1 +1,1 @@ -if you make a mistake, you can undo ('X') or reset ('^') +if you make a mistake, you can undo (backspace) or reset ('R') diff --git a/tutorial/09-springs.text b/tutorial/09-springs.text --- a/tutorial/09-springs.text +++ b/tutorial/09-springs.text @@ -1,1 +1,1 @@ -A spring's length can double when stretched, and halve when compressed +a spring's length can double when stretched, and halve when compressed diff --git a/tutorial/11-conflicts.lock b/tutorial/11-conflicts.lock new file mode 100644 --- /dev/null +++ b/tutorial/11-conflicts.lock @@ -0,0 +1,17 @@ + & & & & & & & & & + & S s s s s " " " & & & & + & # # # " & & + & [ ] " & & + & [ ] % " " " " & + & " % " % " % & & + & " " ] [ # $ % % % & & + & " " " ] [ # % % % & +& " " " " # # " " " " " " " " " & + & O O " & + & # O " # # " " " " " & + & & . o - # # " & +& * ' . o - Z " & + & @ & " " " " Z " & + & & & " " " Z " & + & Z " & + & & & & & & & & & diff --git a/tutorial/11-conflicts.text b/tutorial/11-conflicts.text new file mode 100644 --- /dev/null +++ b/tutorial/11-conflicts.text @@ -0,0 +1,1 @@ +forces conflict if pieces would collide or be pushed in two directions