From e82a3a8c147b34b75a203f66f974f5b3ec21d98c Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Fri, 3 Jun 2016 01:51:28 +0200
Subject: focus

---
 src/Main.hs           | 34 +++++++++++++++++++++++++++++-----
 src/Sequence/Types.hs |  4 +++-
 src/Sequence/Utils.hs | 17 ++++++++++++++++-
 3 files changed, 48 insertions(+), 7 deletions(-)

(limited to 'src')

diff --git a/src/Main.hs b/src/Main.hs
index ea663e8..258e230 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -19,6 +19,11 @@ import qualified Data.CaseInsensitive
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 
+import Data.Bimap (Bimap)
+import qualified Data.Bimap as Bimap
+
+import Data.List
+
 import Data.List
 import Data.Maybe
 
@@ -43,10 +48,14 @@ main = do
                   , commandStyle = OnlyCommands
                   , shellCommands = [ exitCommand "exit"
                                     , helpCommand "help"
+                                    , cmd "entities" listEntities "List all entities"
+                                    , cmd "tip" focusTip "Focus the entity at the top of the queue"
+                                    , cmd "focus" setFocus "Focus a specific entity"
+                                    , cmd "blur" blur "Focus no entity"
+                                    , cmd "remove" remove "Remove the focused entity from the queue"
                                     , cmd "factions" listFactions "List all inhabited factions"
                                     , cmd "members" listFaction "List all members of a faction"
-                                    , cmd "entities" listEntities "List all entities"
-                                    , cmd "align" alignEntity "Align an entity to a faction creating it, if necessary"
+                                    , cmd "align" alignEntity "Align the focused entity to a faction – creating it, if necessary"
                                     ]
                   }
   void $ runShell description haskelineBackend (def :: GameState)
@@ -77,6 +86,21 @@ listFactions = use inhabitedFactions >>= mapM_ (shellPutStrLn . view faction')
 listEntities :: Sh GameState ()
 listEntities = use (gEntities . to Map.keys) >>= mapM_ (shellPutStrLn <=< toName)
 
-alignEntity :: Completable EntityIdentifier -> Completable Faction -> Sh GameState ()
-alignEntity ident' nFaction' = flip withArg nFaction' $ \nFaction -> flip withArg ident' $ \ident -> do
-  gEntities %= Map.adjust (set eFaction nFaction) ident
+alignEntity :: Completable Faction -> Sh GameState ()
+alignEntity = withArg $ \nFaction -> withFocus $ \ident -> gEntities %= Map.adjust (set eFaction nFaction) ident
+
+focusTip, blur :: Sh GameState ()
+focusTip = gFocus <~ use tip
+blur     = gFocus .= Nothing
+
+setFocus :: Completable EntityIdentifier -> Sh GameState ()
+setFocus = withArg $ \ident -> gFocus .= Just ident
+
+remove :: Sh GameState ()
+remove = withFocus $ \ident -> do
+  name <- toName ident
+  confirmation <- askBool ("Are you sure you want to remove ‘" ++ name ++ "’? ") False
+  when confirmation $ do
+    gEntities %= Map.delete ident
+    gEntityNames %= Bimap.delete ident
+    blur
diff --git a/src/Sequence/Types.hs b/src/Sequence/Types.hs
index fd8d7ab..8895569 100644
--- a/src/Sequence/Types.hs
+++ b/src/Sequence/Types.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, ViewPatterns, OverloadedStrings, TemplateHaskell, GeneralizedNewtypeDeriving #-}
 
 module Sequence.Types
-  ( GameState(..), gEntities, gEntityNames
+  ( GameState(..), gEntities, gEntityNames, gFocus
   , Faction, faction, faction'
   , SeqVal(..), seqVal
   , Entity(..), eFaction, eSeqVal
@@ -81,6 +81,7 @@ makeLenses ''EntityIdentifier
 data GameState = GameState
                  { _gEntities    :: Map EntityIdentifier Entity
                  , _gEntityNames :: Bimap EntityIdentifier EntityName
+                 , _gFocus       :: Maybe EntityIdentifier
                  }
 makeLenses ''GameState
 
@@ -88,6 +89,7 @@ instance Default GameState where
   def = GameState
         { _gEntities = def
         , _gEntityNames = Bimap.empty
+        , _gFocus = Nothing
         }
 
 inhabitedFactions :: Getter GameState [Faction]
diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs
index aa92081..aea853d 100644
--- a/src/Sequence/Utils.hs
+++ b/src/Sequence/Utils.hs
@@ -1,7 +1,9 @@
 {-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}
 
 module Sequence.Utils
-  ( withArg, toName, fromName
+  ( withArg, withFocus
+  , askBool
+  , toName, fromName
   ) where
 
 import Sequence.Types
@@ -28,6 +30,7 @@ import Data.List
 
 import System.Console.Shell
 import System.Console.Shell.ShellMonad
+import System.Console.Shell.Backend.Haskeline
 
 
 class Argument a st | a -> st where
@@ -38,6 +41,18 @@ withArg f (Completable str) = arg str >>= \a -> case a of
   Nothing -> shellPutErrLn $ "Could not parse ‘" ++ str ++ "’"
   Just a  -> f a
 
+withFocus :: (EntityIdentifier -> Sh GameState ()) -> Sh GameState ()
+withFocus f = use gFocus >>= \focus -> case focus of
+  Nothing -> shellPutErrLn $ "Currently not focusing any entity"
+  Just id -> f id
+
+askBool :: String -> Bool -> Sh st Bool
+askBool prompt initial = liftIO $ runShell (initialShellDescription { shellCommands = [cmd "y" yes "yes", cmd "n" no "no"], commandStyle = SingleCharCommands, prompt = const $ return prompt, historyEnabled = False }) haskelineBackend initial
+  where
+    yes, no :: Sh Bool ()
+    yes = put True
+    no  = put False
+
 unaligned = view faction' def
   
 toName :: MonadState GameState m => EntityIdentifier -> m String
-- 
cgit v1.2.3