justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Simplify terminals, move towards using tries for commands

Browse Source
This commit is contained in:
justin
2025-08-16 01:11:29 +01:00
parent e04d4fea31
commit 73cdf42e4a
12 changed files with 377 additions and 398 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Terminal.hs
+12 -47
View File
@@ -18,12 +18,9 @@ import Dodge.Data.BlBl
import Dodge.Data.Terminal.Status
import Dodge.Data.WorldEffect
data TerminalInput = TerminalInput
{ --_tiText :: String
_tiSel :: (Int, Int)
}
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
--data TerminalInput = TerminalInput
-- { _tiSel :: (Int, Int)
-- }
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 -- Terminal -> World -> World
, _tmDeathEffect :: TmWdWd
, _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 TmTm
= TmId
-- | TmTmSetPartialCommand (Maybe TerminalCommand)
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
data TerminalLine
= TerminalLineDisplay
{ _tlPause :: Int
, _tlString :: TerminalLineString -- World -> (String, Color)
}
| TerminalLineEffect
data TerminalLine = TLine
{ _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)
--h--deriving (Eq, Show, Read) --Generic, Flat)
--data TCom = TCom
-- { _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
, ''TmTm
[ ''TerminalLineString
, ''TerminalLine
, ''TerminalToggle
, ''EffectArguments
@@ -141,5 +107,4 @@ concat
, ''TerminalCommand
, ''TmWdWd
, ''Terminal
, ''TerminalType
]
src/Dodge/Data/Terminal/Status.hs
+9 -5
View File
@@ -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
deriving Eq
-- | TerminalArgumentInput TerminalCommand
deriving (Eq)
makeLenses ''TerminalStatus
deriveJSON defaultOptions ''TerminalStatus
src/Dodge/Default/Terminal.hs
+8 -8
View File
@@ -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
{ -- _tiText = ""
_tiSel = (0, 0)
}
--defaultTerminalInput :: TerminalInput
--defaultTerminalInput =
-- TerminalInput
-- { -- _tiText = ""
-- _tiSel = (0, 0)
-- }
src/Dodge/Render/HUD.hs
+1 -1
View File
@@ -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
+16 -16
View File
@@ -40,8 +40,8 @@ basicTerminal =
{ _tmDisplayedLines = []
, _tmFutureLines = []
-- , _tmTitle = "TERMINAL"
, _tmScrollCommands = [quitCommand]
, _tmWriteCommands = [helpCommand, commandsCommand]
, _tmScrollCommands = [helpCommand,commandsCommand,quitCommand]
-- , _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)]
++ [TerminalLineEffect 0 (TmTmSetStatus (TerminalTextInput ""))]
++ [ TLine 10 [TerminalLineConst "READY FOR INPUT" termTextColor] (TmTmSetStatus (TerminalTextInput "" 0))]
-- ++ [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)})
. (tmFutureLines ++.~ commandFutureLines s tm w)
%~ ( --(tmInput .~ TerminalInput{ _tiSel = (0, 0)})
(tmFutureLines ++.~ commandFutureLines s tm w)
. (tmCommandHistory %~ take 10 . (s :))
)
src/Dodge/Terminal/Color.hs
+1 -1
View File
@@ -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
+9 -8
View File
@@ -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 (TerminalLineConst str col) = const (str, col)
displayTerminalLineString :: TerminalLineString -> (String, Color)
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) ->
w
& pointTermParams . tmFutureLines %~ tail
& doTmWdWd eff tm
& doTmWdWd g tm
-- Just (TerminalLineEffect _ eff) ->
-- w
-- & pointTermParams . tmFutureLines %~ tail
-- & doTmWdWd eff tm
where
pointTermParams = cWorld . lWorld . terminals . ix (_tmID tm)
src/Dodge/Update/Scroll.hs
+38 -37
View File
@@ -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
Nothing -> tm & tmInput . tiSel .~ (0, 0)
Just (i, _) ->
let newi = (i - yi) `mod` length (scrollCommandStrings w tm)
in tm & setInput newi 0
updatetermsubsel tm = case tm ^? tmInput . tiSel of
Nothing -> tm & tmInput . tiSel .~ (0, 0)
Just (i, j) ->
let newj = (j - yi) `mod` length (getArguments' (scrollCommands tm !! i) tm w)
in tm & setInput i newj
setInput i j tm =
tm
& tmInput . tiSel .~ (i, j)
& tmStatus . tiText .~ comstr ++ arg
where
comstr = scrollCommandStrings w tm !! i
tc = scrollCommands tm !! i
arg = getArguments' tc tm w !! j
-- updatetermsel tm = case tm ^? tmInput . tiSel of
-- Nothing -> tm & tmInput . tiSel .~ (0, 0)
-- Just (i, _) ->
-- let newi = (i - yi) `mod` length (scrollCommandStrings w tm)
-- in tm & setInput newi 0
-- updatetermsubsel tm = case tm ^? tmInput . tiSel of
-- Nothing -> tm & tmInput . tiSel .~ (0, 0)
-- Just (i, j) ->
-- let newj = (j - yi) `mod` length (getArguments' (scrollCommands tm !! i) tm w)
-- in tm & setInput i newj
-- setInput i j tm =
-- tm
-- & tmInput . tiSel .~ (i, j)
-- & tmStatus . tiText .~ comstr ++ arg
-- where
-- comstr = scrollCommandStrings w tm !! i
-- tc = scrollCommands tm !! i
-- 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 = (nullCommand :) . _tmScrollCommands
--scrollCommands :: Terminal -> [TerminalCommand]
--scrollCommands = (nullCommand :) . _tmScrollCommands
scrollCommandStrings :: World -> Terminal -> [String]
scrollCommandStrings w tm = case tm ^? tmPartialCommand . _Just of
Nothing -> map _tcString $ scrollCommands tm
Just tc -> "" : map tail (getArguments tc tm w)
--scrollCommandStrings :: World -> Terminal -> [String]
--scrollCommandStrings w tm = case tm ^? tmPartialCommand . _Just of
-- Nothing -> map _tcString $ scrollCommands tm
-- Just tc -> "" : map tail (getArguments tc tm w)
getArguments' :: TerminalCommand -> Terminal -> World -> [String]
getArguments' tc tm = ("" :) . getArguments tc tm
--getArguments' :: TerminalCommand -> Terminal -> World -> [String]
--getArguments' tc tm = ("" :) . getArguments tc tm
nullCommand :: TerminalCommand
nullCommand =
TerminalCommand
{ _tcString = ""
, _tcAlias = []
, _tcHelp = ""
, _tcEffect = TerminalCommandEffectNone -- \_ _ -> NoArguments []
}
--nullCommand :: TerminalCommand
--nullCommand =
-- TerminalCommand
-- { _tcString = ""
-- , _tcAlias = []
-- , _tcHelp = ""
-- , _tcEffect = TerminalCommandEffectNone -- \_ _ -> NoArguments []
-- }
getArguments :: TerminalCommand -> Terminal -> World -> [String]
getArguments tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of
src/Dodge/WorldEffect.hs
+2 -2
View File
@@ -79,8 +79,8 @@ lineOutputTerminal tls =
{ _tmDisplayedLines = []
, _tmFutureLines = []
-- , _tmTitle = "TERMINAL"
, _tmScrollCommands = [quitCommand]
, _tmWriteCommands = [helpCommand, commandsCommand]
, _tmScrollCommands = [helpCommand,commandsCommand,quitCommand]
-- , _tmWriteCommands = [helpCommand, commandsCommand]
, _tmBootLines = connectionBlurbLines tls
, _tmDeathEffect = TmWdWdDoDeathTriggers
}
src/SimpleTrie.hs
+23
View File
@@ -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)