Simplify terminals, move towards using tries for commands

src/Dodge/Data/Terminal.hs

@@ -18,12 +18,9 @@ import Dodge.Data.BlBl
 import Dodge.Data.Terminal.Status
 import Dodge.Data.WorldEffect
 
-data TerminalInput = TerminalInput
+--data TerminalInput = TerminalInput
-    { --_tiText :: String
+--    { _tiSel :: (Int, Int)
-      _tiSel :: (Int, Int)
+--    }
-    }
-
---deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data Terminal = Terminal
     { _tmID :: Int
@@ -33,52 +30,27 @@ data Terminal = Terminal
     , _tmExternalColor :: Color
     , _tmDisplayedLines :: [(String, Color)]
     , _tmFutureLines :: [TerminalLine]
-    , _tmInput :: TerminalInput
     , _tmScrollCommands :: [TerminalCommand]
-    , _tmWriteCommands :: [TerminalCommand]
+    , _tmDeathEffect :: TmWdWd
-    , _tmDeathEffect :: TmWdWd -- Terminal -> World -> World
     , _tmStatus :: TerminalStatus
     , _tmCommandHistory :: [String]
     , _tmToggles :: M.Map String TerminalToggle
     , _tmPartialCommand :: Maybe TerminalCommand
-    --    , _tmType :: TerminalType
     }
 
---deriving (Eq, Show, Read) --, Generic)
---h--deriving (Eq, Show, Read) --Generic, Flat)
-
-data TerminalType = DefaultTerminal
-
 data TerminalLineString = TerminalLineConst String Color
 
---deriving (Eq, Ord, Show, Read) --Generic, Flat)
+data TerminalLine = TLine
-
-data TmTm
-    = TmId
---    | TmTmSetPartialCommand (Maybe TerminalCommand)
-
---deriving (Eq, Ord, Show, Read) --Generic, Flat)
-
-data TerminalLine
-    = TerminalLineDisplay
-        { _tlPause :: Int
-        , _tlString :: TerminalLineString -- World -> (String, Color)
-        }
-    | TerminalLineEffect
         { _tlPause :: Int
+        , _tlString :: [TerminalLineString] -- World -> (String, Color)
         , _tlEffect :: TmWdWd --Terminal -> World -> World
         }
 
---deriving (Eq, Show, Read) --, Generic)
---h--deriving (Eq, Show, Read) --Generic, Flat)
-
 data TerminalToggle = TerminalToggle
     { _ttTriggerID :: Int
     , _ttDeathEffect :: BlBl
     }
 
---deriving (Eq, Ord, Show, Read) --Generic, Flat)
-
 data EffectArguments
     = NoArguments {_cmdEffect :: [TerminalLine]}
     | OneArgument
@@ -86,9 +58,6 @@ data EffectArguments
         , _argList :: M.Map String [TerminalLine]
         }
 
---deriving (Eq, Show, Read) --, Generic)
---h--deriving (Eq, Show, Read) --Generic, Flat)
-
 data TerminalCommandEffect
     = TerminalCommandArguments EffectArguments
     | TerminalCommandEffectDamageCoding
@@ -100,9 +69,6 @@ data TerminalCommandEffect
     | TerminalCommandEffectSingleCommand WdWd [String]
     | TerminalCommandEffectNone
 
---deriving (Eq, Show, Read) --, Generic)
---h--deriving (Eq, Show, Read) --Generic, Flat)
-
 data TerminalCommand = TerminalCommand
     { _tcString :: String
     , _tcAlias :: [String]
@@ -110,8 +76,11 @@ data TerminalCommand = TerminalCommand
     , _tcEffect :: TerminalCommandEffect -- Terminal -> World -> EffectArguments
     }
 
---deriving (Eq, Show, Read) --, Generic)
+--data TCom = TCom
---h--deriving (Eq, Show, Read) --Generic, Flat)
+--    { _tcomHelp :: String
+--    , _tcomArgs :: Trie Char [TerminalLine]
+--    }
+
 data TmWdWd
     = TmWdId
     | TmWdWdDisconnectTerminal
@@ -122,7 +91,6 @@ data TmWdWd
     | TmTmSetStatus TerminalStatus
     | TmTmSetPartialCommand (Maybe TerminalCommand)
 
-makeLenses ''TerminalInput
 makeLenses ''Terminal
 makeLenses ''TerminalLine
 makeLenses ''TerminalToggle
@@ -131,9 +99,7 @@ makeLenses ''TerminalCommand
 concat
     <$> mapM
         (deriveJSON defaultOptions)
-        [ ''TerminalInput
+        [ ''TerminalLineString
-        , ''TerminalLineString
-        , ''TmTm
         , ''TerminalLine
         , ''TerminalToggle
         , ''EffectArguments
@@ -141,5 +107,4 @@ concat
         , ''TerminalCommand
         , ''TmWdWd
         , ''Terminal
-        , ''TerminalType
         ]

src/Dodge/Data/Terminal/Status.hs

@@ -1,15 +1,19 @@
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
-module Dodge.Data.Terminal.Status
+
-    where
+module Dodge.Data.Terminal.Status where
+
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
 
-data TerminalStatus = TerminalOff | TerminalBusy | TerminalTextInput {_tiText :: String}
+data TerminalStatus
+    = TerminalOff
+    | TerminalBusy
+    | TerminalTextInput {_tiText :: String, _tiSel :: Int}
     | TerminalPressTo {_tptString :: String}
---    | TerminalArgumentInput TerminalCommand
+    --    | TerminalArgumentInput TerminalCommand
-    deriving Eq
+    deriving (Eq)
 
 makeLenses ''TerminalStatus
 deriveJSON defaultOptions ''TerminalStatus

src/Dodge/Default/Terminal.hs

@@ -16,9 +16,9 @@ defaultTerminal =
         , _tmMachineID = 0
         , _tmDisplayedLines = []
         , _tmFutureLines = []
-        , _tmInput = defaultTerminalInput
+--        , _tmInput = defaultTerminalInput
         , _tmScrollCommands = []
-        , _tmWriteCommands = []
+--        , _tmWriteCommands = []
         , _tmDeathEffect = TmWdId
         , _tmStatus = TerminalOff
         , _tmCommandHistory = []
@@ -27,9 +27,9 @@ defaultTerminal =
         , _tmExternalColor = dark magenta
         }
 
-defaultTerminalInput :: TerminalInput
+--defaultTerminalInput :: TerminalInput
-defaultTerminalInput =
+--defaultTerminalInput =
-    TerminalInput
+--    TerminalInput
-        { -- _tiText = ""
+--        { -- _tiText = ""
-         _tiSel = (0, 0)
+--         _tiSel = (0, 0)
-        }
+--        }

src/Dodge/Render/HUD.hs

@@ -384,7 +384,7 @@ drawTerminalDisplay tid cfig w = fromMaybe mempty $ do
     displayTermInput tm = case _tmStatus tm of
         TerminalOff -> id
         TerminalBusy -> (++ [([cFilledRect], white)])
-        TerminalTextInput s ->
+        TerminalTextInput s _ ->
             (++ [(getPromptTM ++ s ++ [cFilledRect], white)])
         TerminalPressTo s ->
             (++ [("PRESS TO "++s, white)])

src/Dodge/Terminal.hs

@@ -40,8 +40,8 @@ basicTerminal =
         { _tmDisplayedLines = []
         , _tmFutureLines = []
 --        , _tmTitle = "TERMINAL"
-        , _tmScrollCommands = [quitCommand]
+        , _tmScrollCommands = [helpCommand,commandsCommand,quitCommand]
-        , _tmWriteCommands = [helpCommand, commandsCommand]
+--        , _tmWriteCommands = [helpCommand, commandsCommand]
         , _tmBootLines = connectionBlurb
         , _tmDeathEffect = TmWdWdDoDeathTriggers
         }
@@ -49,11 +49,11 @@ basicTerminal =
 connectionBlurbLines :: [TerminalLine] -> [TerminalLine]
 connectionBlurbLines tls =
     [ termSoundLine computerBeepingS
-    , TerminalLineDisplay 0 (TerminalLineConst "LOADING TEXT INTERFACE..." termTextColor)
+    , TLine 0 [TerminalLineConst "LOADING TEXT INTERFACE..." termTextColor] TmWdId
     ]
         ++ tls
-       ++ [ TerminalLineDisplay 10 (TerminalLineConst "READY FOR INPUT" termTextColor)]
+       ++ [ TLine 10 [TerminalLineConst "READY FOR INPUT" termTextColor] (TmTmSetStatus (TerminalTextInput "" 0))]
-        ++ [TerminalLineEffect 0 (TmTmSetStatus (TerminalTextInput ""))]
+--        ++ [TerminalLineEffect 0 (TmTmSetStatus (TerminalTextInput "" 0))]
 
 quitCommand :: TerminalCommand
 quitCommand =
@@ -61,7 +61,7 @@ quitCommand =
         { _tcString = "QUIT"
         , _tcAlias = ["Q", "EXIT", "X", "SHUTDOWN", ""]
         , _tcHelp = "Disconnects the terminal."
-        , _tcEffect = TerminalCommandArguments $ NoArguments [TerminalLineEffect 0 TmWdWdDisconnectTerminal]
+        , _tcEffect = TerminalCommandArguments $ NoArguments [TLine 0 [] TmWdWdDisconnectTerminal]
         }
 
 helpCommand :: TerminalCommand
@@ -104,13 +104,13 @@ connectionBlurb :: [TerminalLine]
 connectionBlurb = connectionBlurbLines []
 
 termSoundLine :: SoundID -> TerminalLine
-termSoundLine sid = TerminalLineEffect 0 (TmWdWdTermSound sid)
+termSoundLine sid = TLine 0 [] (TmWdWdTermSound sid)
 
 termTextColor :: Color
 termTextColor = greyN 0.9
 
 getCommands :: Terminal -> [TerminalCommand]
-getCommands tm = _tmScrollCommands tm ++ _tmWriteCommands tm
+getCommands tm = _tmScrollCommands tm -- ++ _tmWriteCommands tm
 
 makeTermLine :: String -> TerminalLine
 makeTermLine = makeColorTermLine termTextColor
@@ -122,7 +122,7 @@ makeColorTermPara :: Color -> String -> [TerminalLine]
 makeColorTermPara col = map (makeColorTermLine col) . makeParagraph 55
 
 makeColorTermLine :: Color -> String -> TerminalLine
-makeColorTermLine col str = TerminalLineDisplay 1 $ TerminalLineConst str col
+makeColorTermLine col str = TLine 1 [TerminalLineConst str col] TmWdId
 
 commandColor :: Color
 commandColor = yellow
@@ -140,7 +140,7 @@ doTerminalCommandEffect tce = case tce of
             ( makeTermLine "Available commands:" :
               makeColorTermPara commandColor (unwords (map _tcString $ getCommands tm))
             )
-    TerminalCommandEffectSingleCommand eff followingLines -> \_ _ -> NoArguments $ TerminalLineEffect 0 (TmWdWdfromWdWd eff) : map makeTermLine followingLines
+    TerminalCommandEffectSingleCommand eff followingLines -> \_ _ -> NoArguments $ TLine 0 [] (TmWdWdfromWdWd eff) : map makeTermLine followingLines
     TerminalCommandEffectNone -> \_ _ -> NoArguments []
 
 argumentHelp :: TerminalCommand -> Terminal -> World -> (String, Maybe [String])
@@ -214,7 +214,7 @@ disconnectTerminal tm =
     (cWorld . lWorld . terminals . ix (_tmID tm) . tmStatus .~ TerminalOff)
         . exitTerminalSubInv
         . ( cWorld . lWorld . terminals . ix (_tmID tm) . tmFutureLines
-                .~ [TerminalLineEffect 0 TmTmClearDisplayedLines]
+                .~ [TLine 0 [] TmTmClearDisplayedLines]
           )
 
 exitTerminalSubInv :: World -> World
@@ -243,7 +243,7 @@ damageCodeCommand =
 togglesToEffects :: Terminal -> M.Map String [TerminalLine]
 togglesToEffects = fmap f . _tmToggles
   where
-    f tt = [TerminalLineEffect 0 $ TmWdWdfromWdWd $ WdWdNegateTrig (_ttTriggerID tt)]
+    f tt = [TLine 0 [] $ TmWdWdfromWdWd $ WdWdNegateTrig (_ttTriggerID tt)]
 
 simpleTermMessage :: [String] -> Terminal
 simpleTermMessage strs = defaultTerminal & tmBootLines .~ map makeTermLine strs
@@ -257,10 +257,10 @@ commandFutureLines s tm w = fromMaybe [errline "^ Invalid command"] $ do
         OneArgument argtype m ->
             let setpartial
                     | null (_tmPartialCommand tm) =
-                        TerminalLineEffect 0 (TmTmSetPartialCommand (Just command)) :
+                        TLine 0 [] (TmTmSetPartialCommand (Just command)) :
                         makeTermPara ("Expects " ++ argtype ++ " as an argument")
                     | otherwise =
-                        TerminalLineEffect 0 (TmTmSetPartialCommand Nothing) :
+                        TLine 0 [] (TmTmSetPartialCommand Nothing) :
                         makeTermPara "No argument input, cancelling"
              in Just $
                     fromMaybe setpartial $
@@ -284,7 +284,7 @@ terminalReturnEffect tmid w = fromMaybe w $ do
 runTerminalString :: String -> Terminal -> World -> World
 runTerminalString s tm w =
     w & cWorld . lWorld . terminals . ix (_tmID tm)
-        %~ ( (tmInput .~ TerminalInput{ _tiSel = (0, 0)})
+        %~ ( --(tmInput .~ TerminalInput{ _tiSel = (0, 0)})
-                . (tmFutureLines ++.~ commandFutureLines s tm w)
+                 (tmFutureLines ++.~ commandFutureLines s tm w)
                 . (tmCommandHistory %~ take 10 . (s :))
            )

src/Dodge/Terminal/Color.hs

@@ -10,6 +10,6 @@ import Control.Lens
 termScreenColor :: Terminal -> Maybe Color
 termScreenColor tm = case tm ^. tmStatus of
     TerminalOff -> Nothing
-    TerminalTextInput _ -> Just green
+    TerminalTextInput _ _ -> Just green
     TerminalPressTo{} -> Just green
     TerminalBusy -> Just white

src/Dodge/Update.hs

@@ -497,22 +497,23 @@ zoneClouds w = w & clZoning .~ foldl' (flip zoneCloud) mempty (w ^. cWorld . lWo
 zoneDusts :: World -> World
 zoneDusts w = w & dsZoning .~ foldl' (flip zoneDust) mempty (w ^. cWorld . lWorld . dusts)
 
-displayTerminalLineString :: TerminalLineString -> World -> (String, Color)
+displayTerminalLineString :: TerminalLineString -> (String, Color)
-displayTerminalLineString (TerminalLineConst str col) = const (str, col)
+displayTerminalLineString (TerminalLineConst str col) = (str, col)
 
 tmUpdate :: Terminal -> World -> World
 tmUpdate tm w = case w ^? cWorld . lWorld . terminals . ix (_tmID tm) . tmFutureLines . ix 0 of
     Nothing -> w
     Just tl | _tlPause tl > 0 -> w & pointTermParams . tmFutureLines . ix 0 . tlPause -~ 1
-    Just (TerminalLineDisplay _ f) ->
+    Just (TLine _ tls g) ->
         w & pointTermParams
             %~ ( (tmFutureLines %~ tail)
-                    . (tmDisplayedLines .:~ displayTerminalLineString f w)
+                    . (tmDisplayedLines %~ (map displayTerminalLineString tls ++))
                )
-    Just (TerminalLineEffect _ eff) ->
+            & doTmWdWd g tm
-        w
+--    Just (TerminalLineEffect _ eff) ->
-            & pointTermParams . tmFutureLines %~ tail
+--        w
-            & doTmWdWd eff tm
+--            & pointTermParams . tmFutureLines %~ tail
+--            & doTmWdWd eff tm
   where
     pointTermParams = cWorld . lWorld . terminals . ix (_tmID tm)
 

src/Dodge/Update/Scroll.hs

@@ -123,32 +123,33 @@ moveCombineSel yi =
         return $ ci & ciSelection %~ scrollSelectionSections yi sss
 
 terminalWheelEvent :: Int -> Int -> World -> World
-terminalWheelEvent yi tmid w
+--terminalWheelEvent yi tmid w
+terminalWheelEvent _ tmid w
     | w & has (input . mouseButtons . ix ButtonRight)
       , Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus =
-        w & cWorld . lWorld . terminals . ix tmid %~ updatetermsubsel
+        w -- & cWorld . lWorld . terminals . ix tmid %~ updatetermsubsel
     | Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus =
-        w & cWorld . lWorld . terminals . ix tmid %~ updatetermsel
+        w -- & cWorld . lWorld . terminals . ix tmid %~ updatetermsel
     | otherwise = w
   where
-    updatetermsel tm = case tm ^? tmInput . tiSel of
+--    updatetermsel tm = case tm ^? tmInput . tiSel of
-        Nothing -> tm & tmInput . tiSel .~ (0, 0)
+--        Nothing -> tm & tmInput . tiSel .~ (0, 0)
-        Just (i, _) ->
+--        Just (i, _) ->
-            let newi = (i - yi) `mod` length (scrollCommandStrings w tm)
+--            let newi = (i - yi) `mod` length (scrollCommandStrings w tm)
-             in tm & setInput newi 0
+--             in tm & setInput newi 0
-    updatetermsubsel tm = case tm ^? tmInput . tiSel of
+--    updatetermsubsel tm = case tm ^? tmInput . tiSel of
-        Nothing -> tm & tmInput . tiSel .~ (0, 0)
+--        Nothing -> tm & tmInput . tiSel .~ (0, 0)
-        Just (i, j) ->
+--        Just (i, j) ->
-            let newj = (j - yi) `mod` length (getArguments' (scrollCommands tm !! i) tm w)
+--            let newj = (j - yi) `mod` length (getArguments' (scrollCommands tm !! i) tm w)
-             in tm & setInput i newj
+--             in tm & setInput i newj
-    setInput i j tm =
+--    setInput i j tm =
-        tm
+--        tm
-            & tmInput . tiSel .~ (i, j)
+--            & tmInput . tiSel .~ (i, j)
-            & tmStatus . tiText .~ comstr ++ arg
+--            & tmStatus . tiText .~ comstr ++ arg
-      where
+--      where
-        comstr = scrollCommandStrings w tm !! i
+--        comstr = scrollCommandStrings w tm !! i
-        tc = scrollCommands tm !! i
+--        tc = scrollCommands tm !! i
-        arg = getArguments' tc tm w !! j
+--        arg = getArguments' tc tm w !! j
 
 scrollRBOption :: Int -> Int -> Int -> Int
 scrollRBOption dy ymax
@@ -156,25 +157,25 @@ scrollRBOption dy ymax
     | dy > 0 = max 0 . subtract dy
     | otherwise = id
 
-scrollCommands :: Terminal -> [TerminalCommand]
+--scrollCommands :: Terminal -> [TerminalCommand]
-scrollCommands = (nullCommand :) . _tmScrollCommands
+--scrollCommands = (nullCommand :) . _tmScrollCommands
 
-scrollCommandStrings :: World -> Terminal -> [String]
+--scrollCommandStrings :: World -> Terminal -> [String]
-scrollCommandStrings w tm = case tm ^? tmPartialCommand . _Just of
+--scrollCommandStrings w tm = case tm ^? tmPartialCommand . _Just of
-    Nothing -> map _tcString $ scrollCommands tm
+--    Nothing -> map _tcString $ scrollCommands tm
-    Just tc -> "" : map tail (getArguments tc tm w)
+--    Just tc -> "" : map tail (getArguments tc tm w)
 
-getArguments' :: TerminalCommand -> Terminal -> World -> [String]
+--getArguments' :: TerminalCommand -> Terminal -> World -> [String]
-getArguments' tc tm = ("" :) . getArguments tc tm
+--getArguments' tc tm = ("" :) . getArguments tc tm
 
-nullCommand :: TerminalCommand
+--nullCommand :: TerminalCommand
-nullCommand =
+--nullCommand =
-    TerminalCommand
+--    TerminalCommand
-        { _tcString = ""
+--        { _tcString = ""
-        , _tcAlias = []
+--        , _tcAlias = []
-        , _tcHelp = ""
+--        , _tcHelp = ""
-        , _tcEffect = TerminalCommandEffectNone -- \_ _ -> NoArguments []
+--        , _tcEffect = TerminalCommandEffectNone -- \_ _ -> NoArguments []
-        }
+--        }
 
 getArguments :: TerminalCommand -> Terminal -> World -> [String]
 getArguments tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of

src/Dodge/WorldEffect.hs

@@ -79,8 +79,8 @@ lineOutputTerminal tls =
         { _tmDisplayedLines = []
         , _tmFutureLines = []
 --        , _tmTitle = "TERMINAL"
-        , _tmScrollCommands = [quitCommand]
+        , _tmScrollCommands = [helpCommand,commandsCommand,quitCommand]
-        , _tmWriteCommands = [helpCommand, commandsCommand]
+--        , _tmWriteCommands = [helpCommand, commandsCommand]
         , _tmBootLines = connectionBlurbLines tls
         , _tmDeathEffect = TmWdWdDoDeathTriggers
         }

src/SimpleTrie.hs

@@ -3,6 +3,7 @@
 
 module SimpleTrie where
 
+import Data.Monoid
 import Control.Lens
 import qualified Data.Map.Strict as M
 
@@ -30,6 +31,28 @@ lookupTrie :: Ord a => [a] -> Trie a b -> Maybe b
 lookupTrie (k : ks) t = _trieChildren t M.!? k >>= lookupTrie ks
 lookupTrie [] t = _trieMVal t
 
+--nextTrie :: Ord a => [a] -> Trie a b -> Maybe (b, Trie a b)
+nextTrie :: [a] -> Trie a b -> Maybe (b, Trie a b)
+nextTrie (k:ks) t = undefined
+nextTrie [] t = Nothing
+
+splitLookupTrie :: Ord a => [a] -> Trie a b -> (Trie a b,Maybe b,Trie a b)
+splitLookupTrie (k:ks) t@(Trie x xs) = case m of
+    Nothing -> (Trie x l,Nothing,Trie x r)
+    Just t' -> let (l',m',r') = splitLookupTrie ks t'
+        in (Trie x (M.insert k l' l),m', Trie x (M.insert k r' r))
+  where
+    (l,m,r) = M.splitLookup k xs
+splitLookupTrie [] t@(Trie x xs) = (Trie Nothing mempty,x, Trie Nothing xs)
+-- the above would be better if it removed empty trie strings; the left trie
+-- will always be empty and the right trie might be empty.
+-- I cannot think of a smart way to do this
+
+firstTrie :: Ord a => Trie a b -> Maybe b
+firstTrie t = case t ^. trieMVal of
+    Just x -> Just x
+    Nothing -> getFirst $ foldMap (First . firstTrie) (t ^. trieChildren)
+
 -- # OPTIONS -Wno-incomplete-uni-patterns #-}
 multiLookupTrie :: Ord a => [a] -> Trie a b -> [([a], b)]
 multiLookupTrie xs t@(Trie my ch)