-- This file is part of Intricacy -- Copyright (C) 2013 Martin Bays -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as -- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} module CursesUIMInstance () where import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Monad.State import Control.Monad.Trans.Maybe import Data.Array import Data.Char (chr, ord) 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 import Safe (maximumBound) import qualified UI.HSCurses.Curses as Curses import qualified UI.HSCurses.CursesHelper as CursesH import CVec import Cache import Command import CursesRender import CursesUI import Database import Frame import GameStateTypes import Hex import InputMode import KeyBindings import MainState import Metagame import Physics import Protocol import ServerAddr import Util drawName :: Bool -> CVec -> Codename -> MainStateT UIM () drawName showScore pos name = do ourName <- gets ((authUser <$>) . curAuth) relScore <- getRelScore name let (attr,col) = case relScore of Just 0 -> (a0,yellow) Just 1 -> (bold,cyan) Just 2 -> (a0,green) Just 3 -> (bold,green) Just (-1) -> (bold,magenta) Just (-2) -> (a0,red) Just (-3) -> (bold,red) _ -> if ourName == Just name then (bold,white) else (a0,white) lift $ drawStrCentred attr col pos (name ++ if showScore then " " ++ maybe "" show relScore else "") drawActiveLock :: CVec -> ActiveLock -> MainStateT UIM () drawActiveLock pos al@(ActiveLock name i) = do accessed <- accessedAL al drawNameWithChar pos name (if accessed then green else white) (lockIndexChar i) drawNameWithChar :: CVec -> Codename -> ColPair -> Char -> MainStateT UIM () drawNameWithChar pos name charcol char = do drawName False (pos +^ CVec 0 (-1)) name lift $ drawStr bold charcol (pos +^ CVec 0 1) [':',char] drawNote :: CVec -> NoteInfo -> MainStateT UIM () drawNote pos note = case noteBehind note of Just al -> drawActiveLock pos al Nothing -> drawPublicNote pos (noteAuthor note) where drawPublicNote pos name = drawNameWithChar pos name magenta 'P' fillBox :: CVec -> CVec -> Int -> Gravity -> [CVec -> MainStateT UIM ()] -> MainStateT UIM Int fillBox (CVec t l) (CVec b r) width grav draws = do offset <- gets listOffset let half = width`div`2 starty = (if grav == GravDown then b else t) cv = (b+t)`div`2 ch = (l+r)`div`2 gravCentre = case grav of GravDown -> CVec b ch GravUp -> CVec t ch GravLeft -> CVec cv l GravRight -> CVec cv r GravCentre -> CVec cv ch locs = sortBy (compare `on` dist) $ concat [ [CVec j (l + margin + (width + 1) * i) | i <- [0 .. (r - l - (2 * margin)) `div` (width + 1)]] | j <- [t..b] , let margin = if even (j-starty) then half else width ] 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 ++ [drawChar '<'] else draws (selDraws,allDrawn) = if length draws' > na then (take (na-1) draws' ++ [drawChar '>'], False) else (take na draws', True) 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 ] drawLockInfo al@(ActiveLock name i) lockinfo = do (h,w) <- liftIO Curses.scrSize let [left,vcentre,right] = [ (k+2*i)*w`div`6 + (1-k) | k <- [0,1,2] ] let [top,bottom] = [6, h-2] let hcentre = (top+bottom)`div`2 - 1 ourName <- gets ((authUser <$>) . curAuth) (lockTop, lockBottom) <- (fromJust<$>)$ runMaybeT $ msum [ do 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) return (hcentre - size - 1, hcentre + size + 1) , lift $ do drawActiveLock (CVec hcentre vcentre) al return (hcentre - 1, hcentre + 1) ] startOn <- if public lockinfo then lift $ drawStrCentred bold magenta (CVec (lockTop-1) vcentre) "Public" >> return (lockTop-1) else if null $ accessedBy lockinfo then lift $ drawStrCentred a0 white (CVec (lockTop-1) vcentre) "None" >> return (lockTop-1) else fillBox (CVec (top+1) (left+1)) (CVec (lockTop-1) (right-1)) 5 GravDown $ [ (`drawNote` note) | note <- lockSolutions lockinfo ] lift $ drawStrCentred a0 white (CVec (startOn-1) vcentre) "Solutions:" undecls <- gets undeclareds if isJust $ guard . (|| public lockinfo) . (`elem` accessedBy lockinfo) =<< ourName then lift $ drawStrCentred a0 green (CVec (lockBottom+1) vcentre) "Accessed!" 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 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 ] lift $ drawStrCentred a0 white (CVec (lockBottom+2) vcentre) "Notes held:" if null $ notesSecured lockinfo then lift $ 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 ] data HelpReturn = HelpNone | HelpDone | HelpContinue Int showHelpPaged :: Int -> InputMode -> HelpPage -> UIM Bool showHelpPaged from mode page = showHelpPaged' from mode page >>= \case HelpNone -> return False HelpDone -> return True HelpContinue from' -> do drawPrompt False "[MORE]" getInput IMTextInput showHelpPaged from' mode page showHelpPaged' :: Int -> InputMode -> HelpPage -> UIM HelpReturn showHelpPaged' from mode HelpPageInput = do bdgs <- nub <$> getBindings mode erase (h,w) <- liftIO Curses.scrSize let bdgWidth = 39 showKeys chs = intercalate "/" (showKey <$> chs) maxkeyslen = maximum $ length . showKeys . map fst <$> groupBy ((==) `on` snd) bdgs drawStrCentred a0 cyan (CVec 0 (w`div`2)) "Bindings:" let groups = filter (not . null . describeCommand . snd . head) $ drop from $ groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs let draws = [ drawStr a0 cyan (CVec (y+2) (x*bdgWidth) ) $ keysStr ++ replicate pad ' ' ++ ": " ++ desc | ((keysStr,pad,desc),(x,y)) <- zip [ (keysStr,pad,desc) | group <- groups , let cmd = snd $ head group , let desc = describeCommand cmd , let chs = fst <$> group , let keysStr = showKeys chs , let pad = max 0 $ minimum [maxkeyslen + 1 - length keysStr, bdgWidth - length desc - length keysStr - 1 - 1] ] $ (`divMod` (h-3)) <$> [0..] , (x+1)*bdgWidth < w] sequence_ draws refresh return $ if length draws < length groups then HelpContinue $ from + length draws else HelpDone showHelpPaged' from IMInit HelpPageGame = drawBasicHelpPage from ("INTRICACY",magenta) (initiationHelpText,magenta) showHelpPaged' from IMMeta HelpPageGame = drawBasicHelpPage from ("INTRICACY",magenta) (metagameHelpText,magenta) showHelpPaged' from IMMeta (HelpPageInitiated n) = drawBasicHelpPage from ("Initiation complete",magenta) (initiationCompleteText n,magenta) showHelpPaged' from IMEdit HelpPageFirstEdit = drawBasicHelpPage from ("Your first lock:",magenta) (firstEditHelpText,green) showHelpPaged' _ _ _ = return HelpNone drawBasicHelpPage :: Int -> (String,ColPair) -> ([String],ColPair) -> UIM HelpReturn drawBasicHelpPage from (title,titleCol) (body,bodyCol) = do erase (h,w) <- liftIO Curses.scrSize let strs = drop from $ if w >= maximum (length <$> metagameHelpText) then body else let wrap max = wrap' max max wrap' _ _ [] = [] wrap' max left (w:ws) = if 1+length w > left then if left == max then take max w ++ "\n" ++ wrap' max max (drop max w : ws) else '\n' : wrap' max max (w:ws) else let prepend = if left == max then w else ' ':w in prepend ++ wrap' max (left - length prepend) ws in lines . wrap w . words $ unwords body top = max 0 $ (h - length strs) `div` 2 drawStrCentred a0 titleCol (CVec top $ w`div`2) title let draws = [drawStrCentred a0 bodyCol (CVec y $ w`div`2) str | (y,str) <- zip [top+2..h-2] strs ] sequence_ draws return $ if length draws < length strs then HelpContinue $ from + length draws else HelpDone charify :: Curses.Key -> Maybe Char charify key = case key of Curses.KeyChar ch -> Just ch Curses.KeyBackspace -> Just '\b' Curses.KeyLeft -> Just '4' Curses.KeyRight -> Just '6' Curses.KeyDown -> Just '2' Curses.KeyUp -> Just '8' Curses.KeyHome -> Just '7' Curses.KeyNPage -> Just '3' Curses.KeyPPage -> Just '9' Curses.KeyEnd -> Just '1' _ -> Nothing handleEsc k@(Curses.KeyChar '\ESC') = do Curses.timeout 100 cch <- Curses.getch Curses.timeout (-1) return $ if cch == -1 then k else Curses.KeyChar $ chr $ fi cch+128 handleEsc k = return k instance UIMonad (StateT UIState IO) where runUI m = evalStateT m nullUIState drawMainState = do lift erase s <- get lift . drawTitle =<< getTitle lift drawMsgLine drawMainState' s lift refresh where drawMainState' PlayState { psCurrentState=st, psLastAlerts=alerts, wrenchSelected=wsel, psFrame=frame, psTutLevel=tutLevel } = 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 _ = True drawMainState' ReplayState {} = do lift . drawState [] False [] =<< gets rsCurrentState lift $ drawCursorAt Nothing drawMainState' EditState { esGameState=st, selectedPiece=selPiece, selectedPos=selPos, esFrame=frame } = lift $ do 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 drawCursorAt Nothing (h,w) <- liftIO Curses.scrSize when (h<15 || w<30) $ liftIO CursesH.end >> error "Terminal too small!" let centre = CVec (h`div`2) (w`div`2) drawStrCentred bold white (centre +^ CVec (-5) 0) "I N T R I C A C Y" bdgs <- getBindings IMInit doDrawAt (centre +^ CVec 5 0) . alignDraw GravCentre 0 $ bindingsDraw bdgs [CmdSolveInit Nothing] <> greyDraw " solve lock" doDrawAt (centre +^ CVec 6 0) . alignDraw GravCentre 0 $ bindingsDraw bdgs [CmdHelp] <> greyDraw " help" 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 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 , abs (hy v') < 2 && hx v' >= 0 && hz v' <= 0 , v' `Map.member` accessible || (isLast v && h == hu) , solved v || solved v' ] drawInitLock zero mapM_ drawInitLock $ Map.keys accessible where accessible = accessibleInitLocks tutSolved initLocks 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 | 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 modify $ \ms -> ms { listOffsetMax = True } let ourName = authUser <$> auth let selName = listToMaybe names let home = isJust ourName && ourName == selName (h,w) <- liftIO Curses.scrSize when (h<20 || w<40) $ liftIO CursesH.end >> error "Terminal too small!" bdgs <- lift $ getBindings IMMeta lift $ do drawCursorAt Nothing let serverBdgsDraw = bindingsDraw bdgs [CmdSetServer, CmdToggleCacheOnly] lockBdgsDraw = bindingsDraw bdgs $ CmdEdit : [CmdPlaceLock Nothing | path /= ""] leftBdgsWidth = (+3) . maximum $ drawWidth <$> [serverBdgsDraw, lockBdgsDraw] helpDraw = bindingsDraw bdgs [CmdInitiation] <> greyDraw " initiation " <> bindingsDraw bdgs [CmdHelp] <> greyDraw " help" serverTextDraw = greyDraw . take (w - leftBdgsWidth - drawWidth helpDraw - 1) $ " Server: " ++ saddrStr saddr ++ (if cOnly then " (offline mode) " else "") lockBdgsDraw' = bindingsDraw bdgs $ CmdSelectLock : if path == "" then [] else [CmdNextLock, CmdPrevLock] lockTextDraw = greyDraw . take (w - leftBdgsWidth - drawWidth lockBdgsDraw' - 1) $ " Lock: " ++ path ++ replicate 5 ' ' doDrawAt (CVec 0 0) $ alignDraw GravLeft leftBdgsWidth serverBdgsDraw <> serverTextDraw doDrawAt (CVec 0 0) $ alignDraw GravRight w helpDraw doDrawAt (CVec 1 0) $ alignDraw GravLeft leftBdgsWidth lockBdgsDraw <> lockTextDraw <> lockBdgsDraw' doDrawAt (CVec 2 $ maximum [w`div`3+1, w`div`2 - 13]) $ bindingsDraw bdgs [CmdSelCodename Nothing] maybe (return ()) (drawName True (CVec 2 (w`div`2))) selName void.runMaybeT $ MaybeT (return selName) >>= lift . getUInfoFetched 300 >>= \(FetchedRecord fresh err muirc) -> lift $ do lift $ do unless fresh $ drawAtCVec (Glyph '*' red bold) $ CVec 2 (w`div`2+7) maybe (return ()) sayError err when (fresh && (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] 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 $ CmdShowRetired : [CmdPlayLockSpec Nothing | not (null retired)] Nothing -> do sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) lockinfo | (i,Just lockinfo) <- assocs $ userLocks uinfo ] unless (null $ elems $ userLocks uinfo) $ lift $ doDrawAt (CVec 5 (w`div`3)) $ bindingsDraw bdgs $ CmdSolve Nothing : [CmdViewSolution Nothing | isJust ourName] when (isJust ourName && ourName == selName) $ do rnames <- liftIO $ readTVarIO rnamestvar unless (null rnames) $ void $ fillBox (CVec 2 0) (CVec 5 (w`div`3)) 3 GravCentre [ \pos -> drawName False pos name | name <- rnames ] unless (null undecls) $ let declareBdgDraw = bindingsDraw bdgs [CmdDeclare Nothing] declareText = " Undeclared solutions:" y = 4 leftBound = w`div`3 + 1 undeclsWidth = 1 + 6 * length undecls declareDraw = if leftBound + drawWidth declareBdgDraw + length declareText + undeclsWidth >= w then declareBdgDraw else declareBdgDraw <> stringDraw bold white declareText width = drawWidth declareDraw + undeclsWidth left = max leftBound ((w - width) `div` 2) in do lift $ doDrawAt (CVec y left) declareDraw void $ fillBox (CVec y $ left + drawWidth declareDraw + 1) (CVec y (w-1)) 5 GravLeft [ (`drawActiveLock` al) | Undeclared _ _ al <- undecls ] when (ourName /= selName) $ void $ runMaybeT $ do sel <- liftMaybe selName us <- liftMaybe ourName ourUInfo <- mgetUInfo us let accessed = [ ActiveLock us i | i<-[0..2] , Just lock <- [ userLocks ourUInfo ! i ] , public lock || selName `elem` (Just <$> accessedBy lock) ] guard $ not $ null accessed let str = "has accessed:" let s = (w-(4 + length str + 6*length accessed))`div`2 let y = 4 lift $ do drawName False (CVec y (s+1)) sel lift $ drawStrGrey (CVec y $ s+4) str void $ fillBox (CVec y (s+4+length str+1)) (CVec y (w-1)) 5 GravLeft $ [ (`drawActiveLock` al) | al <- accessed] reportAlerts _ alerts = do mapM_ drawAlert alerts unless (null alerts) $ do refresh liftIO $ threadDelay $ 5*10^4 where drawAlert (AlertCollision pos) = drawAt cGlyph pos drawAlert _ = return () cGlyph = Glyph '!' 0 a0 clearMessage = say "" drawMessage = say drawPrompt full s = liftIO (void $ Curses.cursSet Curses.CursorVisible) >> say s endPrompt = say "" >> liftIO (void $ Curses.cursSet Curses.CursorInvisible) drawError = sayError showHelp = showHelpPaged 0 getChRaw = (charify<$>) $ liftIO $ CursesH.getKey (return ()) >>= handleEsc setUIBinding mode cmd ch = modify $ \s -> s { uiKeyBindings = Map.insertWith (\ [bdg] bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs) mode [(ch,cmd)] $ uiKeyBindings s } getUIBinding mode cmd = do bdgs <- getBindings mode return $ maybe "" showKey $ findBinding bdgs cmd initUI = do liftIO CursesH.start cpairs <- liftIO $ colorsToPairs [ (f, CursesH.black) | f <- [ CursesH.white, CursesH.red, CursesH.green, CursesH.yellow , CursesH.blue, CursesH.magenta, CursesH.cyan] ] modify $ \s -> s {dispCPairs = cpairs} readBindings return True endUI = do writeBindings liftIO CursesH.end unblockInput = return $ Curses.ungetCh 0 suspend = do liftIO $ do CursesH.suspend Curses.resetParams redraw redraw = liftIO $ do Curses.endWin Curses.refresh warpPointer _ = return () getUIMousePos = return Nothing setYNButtons = return () onNewMode _ = say "" withNoBG = id toggleColourMode = modify $ \s -> s {monochrome = not $ monochrome s} impatience ticks = do when (ticks>20) $ say "Waiting for server (^C to abort)..." unblock <- unblockInput liftIO $ forkIO $ threadDelay 50000 >> unblock cmds <- getInput IMImpatience return $ CmdQuit `elem` cmds 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 return [CmdRedraw] else do let mch = charify key unblockBinding = (toEnum 0, CmdRefresh) -- c.f. unblockInput above flip (maybe $ return []) mch $ \ch -> if mode == IMTextInput then return [ CmdInputChar ch `fromMaybe` lookup ch [unblockBinding] ] else maybeToList . lookup ch . (unblockBinding:) <$> getBindings mode