intricacy 0.8.2.1 → 0.9.0.0
raw patch · 69 files changed
+3786/−533 lines, 69 filesdep +cryptondep +file-embeddep +sdl2dep −cryptonitedep ~basedep ~bytestringdep ~containerssetup-changed
Dependencies added: crypton, file-embed, sdl2, sdl2-gfx, sdl2-mixer, sdl2-ttf
Dependencies removed: cryptonite
Dependency ranges changed: base, bytestring, containers, filepath, hscurses, memory, smtp-mail, time, vector, xml-conduit
Files
- AsciiLock.hs +8/−8
- BUILD +8/−9
- BinaryInstances.hs +7/−1
- BoardColouring.hs +3/−3
- CVec.hs +1/−1
- Cache.hs +6/−7
- Command.hs +50/−49
- CursesRender.hs +1/−1
- CursesUI.hs +2/−1
- CursesUIMInstance.hs +51/−51
- Database.hs +36/−13
- EditGameState.hs +1/−3
- Font.hs +19/−0
- Frame.hs +2/−2
- GameState.hs +10/−10
- GameStateTypes.hs +1/−1
- GraphColouring.hs +4/−8
- Hex.lhs +1/−1
- Init.hs +14/−4
- InputMode.hs +1/−1
- Interact.hs +140/−90
- InteractUtil.hs +34/−28
- Intricacy.hs +20/−5
- KeyBindings.hs +79/−57
- Lock.hs +4/−4
- MainState.hs +38/−42
- Maxlocksize.hs +1/−1
- Metagame.hs +5/−2
- Mundanities.hs +10/−1
- NEWS +7/−0
- Physics.hs +18/−12
- Protocol.hs +6/−1
- README +2/−2
- SDL2Glyph.hs +48/−0
- SDL2Keys.hs +90/−0
- SDL2Render.hs +345/−0
- SDL2RenderCache.hs +426/−0
- SDL2UI.hs +1003/−0
- SDL2UIMInstance.hs +956/−0
- SDLGlyph.hs +1/−1
- SDLRender.hs +1/−1
- SDLUI.hs +8/−7
- SDLUIMInstance.hs +4/−2
- Server.hs +51/−4
- ServerAddr.hs +2/−3
- Setup.hs +1/−1
- SimpleCache.hs +42/−0
- Util.hs +1/−1
- Version.hs +4/−2
- initiation/EQU.lock +17/−0
- initiation/EQU.text +1/−0
- initiation/ICE.text +1/−1
- initiation/JIT.lock +17/−0
- initiation/JIT.text +1/−0
- initiation/KCK.lock +17/−0
- initiation/KCK.text +1/−0
- initiation/PKR.lock +17/−0
- initiation/PKR.text +1/−0
- initiation/RAT.lock +2/−2
- initiation/REP.lock +6/−6
- initiation/RUN.lock +0/−17
- initiation/RUN.text +0/−1
- initiation/initiation.map +3/−3
- intricacy.cabal +94/−45
- tutorial/03-time.lock +15/−15
- tutorial/08-traps.text +1/−1
- tutorial/09-springs.text +1/−1
- tutorial/11-conflicts.lock +17/−0
- tutorial/11-conflicts.text +1/−0
AsciiLock.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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)
BUILD view
@@ -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!
BinaryInstances.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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"
BoardColouring.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
CVec.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as
Cache.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
Command.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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"
CursesRender.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as
CursesUI.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
CursesUIMInstance.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
Database.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
EditGameState.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
+ Font.hs view
@@ -0,0 +1,19 @@+-- This file is part of Intricacy+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE TemplateHaskell #-}++module Font where++import qualified Data.ByteString as BS+import Data.FileEmbed (embedFile)++veraMoBd :: BS.ByteString+veraMoBd = $(embedFile "VeraMoBd.ttf")
Frame.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
GameState.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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 ]
GameStateTypes.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as
GraphColouring.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
Hex.lhs view
@@ -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 ]
Init.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
InputMode.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as
Interact.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
InteractUtil.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
Intricacy.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
KeyBindings.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
Lock.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
MainState.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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."
Maxlocksize.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as
Metagame.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
Mundanities.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
NEWS view
@@ -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
Physics.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
Protocol.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
README view
@@ -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.
+ SDL2Glyph.hs view
@@ -0,0 +1,48 @@+-- This file is part of Intricacy+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++module 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)
+ SDL2Keys.hs view
@@ -0,0 +1,90 @@+-- This file is part of Intricacy+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++module 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'
+ SDL2Render.hs view
@@ -0,0 +1,345 @@+-- This file is part of Intricacy+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++-- |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)
+ SDL2RenderCache.hs view
@@ -0,0 +1,426 @@+-- This file is part of Intricacy+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# 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)
+ SDL2UI.hs view
@@ -0,0 +1,1003 @@+-- This file is part of Intricacy+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# 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 (<now) . nextAnimFrameAt)+ when anim $+ modify $ \ds -> 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
+ SDL2UIMInstance.hs view
@@ -0,0 +1,956 @@+-- This file is part of Intricacy+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# 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 (<now) . nextAnimFrameAt)+ unless (null cmds) clearMsg+ return $ cmds ++ [CmdRefresh | uiChanged || animFrameReady || unblockEvent]+ where+ nubMouseMotions =+ -- drop all but last mouse motion and resize events+ let nubMouseMotions' (False,r) (mm@MouseMotionEvent {}:evs) = mm:nubMouseMotions' (True,r) evs+ nubMouseMotions' (m,False) (wr@(WindowSizeChangedEvent _):evs) = wr:nubMouseMotions' (m,True) evs+ nubMouseMotions' b (MouseMotionEvent _:evs) = nubMouseMotions' b evs+ nubMouseMotions' b (WindowSizeChangedEvent _:evs) = nubMouseMotions' b evs+ nubMouseMotions' b (ev:evs) = ev:nubMouseMotions' b evs+ nubMouseMotions' _ [] = []+ in reverse . nubMouseMotions' (False,False) . reverse+ setPaintFromCmds cmds = sequence_+ [ modify $ \s -> 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 ]
SDLGlyph.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as
SDLRender.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as
SDLUI.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
SDLUIMInstance.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
Server.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
ServerAddr.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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))
Setup.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as
+ SimpleCache.hs view
@@ -0,0 +1,42 @@+-- This file is part of Intricacy+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++module 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
Util.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as
Version.hs view
@@ -1,5 +1,5 @@ -- This file is part of Intricacy--- Copyright (C) 2013 Martin Bays <mbays@sdf.org>+-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org> -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as@@ -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
+ initiation/EQU.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " # % # " " " " + " # % # " " + " # " O " { " " + " # 7 % " [ " " " # # "+ " # 7 % % " [ " # " " + " 7 % % " " " % % # " " + " 7 % % % " " " % # # " +" % % % % # o - % # # # " + " % # C C % Z % S S # " + " Z O % % % " + " " Z % " +" * ' Z % " + " @ " % & & & & & % " + " " " % # C C % 7 % " + " % % % % % % 7 % " + " " " " " " " " "
+ initiation/EQU.text view
@@ -0,0 +1,1 @@+Force equilibrium
initiation/ICE.text view
@@ -1,1 +1,1 @@-Obligatory slippy-slidey ice world+Slippy-slidey
+ initiation/JIT.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " ~ ~ ~ ~ ~ # # " " " " + " ~ ~ ~ ~ # # " " + " ~ ~ ~ ~ ~ # # " # " + " ~ ~ ~ $ " O # # # # # "+ " ~ ~ ~ ~ ~ # # # 7 " " + " ~ ~ ~ ~ ~ 7 " " + " ~ ~ ~ ~ ~ O % D " " " " " +" ~ & & & & & & & & " + " ~ ~ ~ ~ # # # & " + " & " + " " & & & & & & " +" * ' & C C C C C C C C C C " + " @ " % % % % % % % % % % " + " " " % % % % % % % % " + " % % % % % % % % " + " " " " " " " " "
+ initiation/JIT.text view
@@ -0,0 +1,1 @@+Just in time
+ initiation/KCK.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " % % % S S # " " " " + " % # % # # " " + " . o " % % # # " " + " % O " % # % % % # # # "+ " " % % % " " + " & & s s " % % % % " " + " & # & ' " { % # % " +" & & . o # " " # % % % " + " \ ' O O ' # % % % " + " % o % " " " " o % # % " + " " % # / % % % " +" * ' % # c c c c c c % " + " @ " % % % # % % % % " + " " " % Z % % % % # % " + " Z % % % % " + " " " " " " " " "
+ initiation/KCK.text view
@@ -0,0 +1,1 @@+Be faster
+ initiation/PKR.lock view
@@ -0,0 +1,17 @@+ " " " " " " " " " + " { % s s & " " " " + " [ ] % & " " + " & s s s s % ] % & " " + " & % ] ] & & & "+ " 1 # C C C C % ] ) % O & " " + " 1 " " ) # & " " + " 7 # { % # # # " +" 7 # # % # " + " % % % # % [ " + " % \ ' % # % ( " + " " o - o - ( " +" * ' ` # % % # ( " + " @ " # # # # 7 # ( " + " " " # 7 # % % " + " 7 " + " " " " " " " " "
+ initiation/PKR.text view
@@ -0,0 +1,1 @@+Poker
initiation/RAT.lock view
@@ -2,8 +2,8 @@ " " " " " " # " " " # # " # " - " # # # "- " # # % O O O " " " # " " + " # # # # "+ " # # # % O O O " " " # " " " # % % O O O " " " # " " " % S S S S S S " # " " # # # # % % % % % " # # "
initiation/REP.lock view
@@ -1,17 +1,17 @@ " " " " " " " " " " } " " " " " & } # S S % " " - " # & } & & % % " " - " 9 " & } & % % % "- " % 9 # & } & " " - " % 9 " & } & " " + " ~ & } & & % % " " + " 9 # & } & % % % "+ " % 9 " & } & " " + " % 9 ~ & } & " " " % 9 # & & o " " % 9 \ ' O / ` # " " % o O # # " " % % S # / O # " " " % # O # " -" * ' % O # " +" * ' % % O # " " @ " % % % % % O # " " " " % " - " # " + " % " " " " " " " " " "
− initiation/RUN.lock
@@ -1,17 +0,0 @@- " " " " " " " " " - " ~ ~ ~ ~ ~ # # " " " " - " ~ ~ ~ ~ # # " " - " ~ ~ ~ ~ ~ # # " # " - " ~ ~ ~ $ " O # # # # # "- " ~ ~ ~ ~ ~ # # # 7 " " - " ~ ~ ~ ~ ~ 7 " " - " ~ ~ ~ ~ ~ O % D " " " " " -" ~ & & & & & & & & " - " ~ ~ ~ ~ # # # & " - " & " - " " & & & & & & " -" * ' & C C C C C C C C C C " - " @ " % % % % % % % % % % " - " " " % % % % % % % % " - " % % % % % % % % " - " " " " " " " " "
− initiation/RUN.text
@@ -1,1 +0,0 @@-Quick!
initiation/initiation.map view
@@ -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"]]
intricacy.cabal view
@@ -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
tutorial/03-time.lock view
@@ -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 % " + " " " " " " " "
tutorial/08-traps.text view
@@ -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')
tutorial/09-springs.text view
@@ -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
+ tutorial/11-conflicts.lock view
@@ -0,0 +1,17 @@+ & & & & & & & & & + & S s s s s " " " & & & & + & # # # " & & + & [ ] " & & + & [ ] % " " " " &+ & " % " % " % & & + & " " ] [ # $ % % % & & + & " " " ] [ # % % % & +& " " " " # # " " " " " " " " " & + & O O " & + & # O " # # " " " " " & + & & . o - # # " & +& * ' . o - Z " & + & @ & " " " " Z " & + & & & " " " Z " & + & Z " & + & & & & & & & & &
+ tutorial/11-conflicts.text view
@@ -0,0 +1,1 @@+forces conflict if pieces would collide or be pushed in two directions