loop/src/Dodge/Debug/Terminal.hs

{-# LANGUAGE TupleSections #-}

module Dodge.Debug.Terminal where

import Dodge.Item.Location.Initialize
import Control.Applicative
import Control.Lens
--import Control.Monad
--import Data.List
import Data.Maybe
import qualified Data.Text as T
import Dodge.Creature
import Dodge.Data.Universe
import Dodge.Inventory.Add
import Dodge.Item
--import Dodge.Menu.PushPop
import qualified IntMapHelp as IM
import LensHelp
import MaybeHelp
import Text.Read (readMaybe)

applyTerminalString :: [String] -> Universe -> Universe
applyTerminalString ss = case ss of
    [] -> id
    [s] -> applyTerminalCommand s
    (s : ss') -> applyTerminalCommandArguments s ss'

applyTerminalCommand :: String -> Universe -> Universe
applyTerminalCommand s = case s of
    "NOCLIP" -> uvConfig . debug_booleans . at Noclip %~ toggleJust
    ['L', x] ->
            (uvWorld . cWorld . lWorld %~ initSpecificCrItemLocations 0)
        . (uvWorld . cWorld . lWorld . creatures . ix 0 . crInv .~ IM.fromList (zip [0 ..] $ inventoryX x))
            . (uvWorld . cWorld . lWorld . creatures . ix 0 . crInvCapacity .~ 50)
    ['I','S',x,y] ->  uvWorld . cWorld . lWorld . creatures . ix 0 . crInvCapacity .~ read [x,y]
    "GODON" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crMaterial .~ Crystal
    "GODOFF" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crMaterial .~ Flesh
    _ -> id

applyTerminalCommandArguments :: String -> [String] -> Universe -> Universe
applyTerminalCommandArguments command args u = case command of
    "ITEM" -> fromMaybe u $ do
        (ibt, n) <- parseItem args
        return $ u & uvWorld %~ flip (foldr ($)) (replicate n (snd . createPutItem (itemFromBase ibt)))
    "DEX" -> fromMaybe u $ do
        x <- readMaybe =<< args ^? _head
        return $ u & ypoint . crStatistics . dexterity .~ x
    "STR" -> fromMaybe u $ do
        x <- readMaybe =<< args ^? _head
        return $ u & ypoint . crStatistics . strength .~ x
    "INT" -> fromMaybe u $ do
        x <- readMaybe =<< args ^? _head
        return $ u & ypoint . crStatistics . intelligence .~ x
    _ -> u
  where
    ypoint = uvWorld . cWorld . lWorld . creatures . ix 0

parseItem :: [String] -> Maybe (ItemBaseType, Int)
parseItem (x : xs) =
    (readMaybe (x ++ " {_xNum=" ++ show (parseNum xs) ++ "}") <&> (,1))
        <|> (readMaybe x <&> (,parseNum xs))
        <|> (readMaybe ("CRAFT " ++ x) <&> (,parseNum xs))
        <|> (readMaybe ("HELD {_ibtHeld=" ++ x ++ "}") <&> (,parseNum xs))
        <|> (readMaybe ("EQUIP {_ibtEquip=" ++ x ++ "}") <&> (,parseNum xs))
        <|> (readMaybe ("LEFT {_ibtLEFT=" ++ x ++ "}") <&> (,parseNum xs))
        <|> (readMaybe ("HELD (" ++ x ++ " {_xNum=" ++ show (parseNum xs) ++ "}") <&> (,1))
        <|> parseItem (xs & ix 0 .++~ (x ++ " "))
parseItem [] = Nothing

parseNum :: [String] -> Int
parseNum xs = fromMaybe 1 $ xs ^? ix 0 >>= readMaybe

showTerminalError :: String -> String -> Universe -> Universe
showTerminalError cmd s = uvScreenLayers .:~ InputScreen (T.pack cmd) s

applySetTerminalString :: String -> Universe -> Universe
applySetTerminalString [] = id
applySetTerminalString var = case key' of
    "" -> showTerminalError ("set " ++ var) ("Unable to read as argument as float: " ++ val)
    "hp" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crHP .~ round (fromJust val')
    "invcap" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crInvCapacity .~ round (fromJust val')
    "mass" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crMass .~ fromJust val'
    "mvspeed" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crMvType . mvSpeed .~ fromJust val'
    _ -> showTerminalError ("set " ++ var) ("Invalid set command: " ++ key) -- never reached?
  where
    (key, val) = getSplitString var
    val' = readMaybe val :: Maybe Float
    key' = if isNothing val' then "" else key

--autoCompleteTerminal :: String -> String -> Universe -> IO (Maybe Universe)
--autoCompleteTerminal s _ =
--    return
--        . (popScreen' >=> pushScreen' (InputScreen (T.pack input_str) valid_commands))
--  where
--    (key, val) = getSplitString $ tail s
--    command_options = case val of
--        "" -> filter (isInfixOf key) (validTerminalCommands "")
--        _ -> filter (isInfixOf val) (validTerminalCommands key)
--    -- basic autocomplete if single option available (or as far as possible)
--    input_str = case (key, val) of
--        (_, "") ->
--            if length command_options == 1
--                then ">" ++ head command_options ++ " "
--                else ">" ++ longestCommonPrefix command_options
--        _ ->
--            if length command_options == 1
--                then ">" ++ key ++ " " ++ head command_options ++ " "
--                else
--                    if null command_options
--                        then s
--                        else ">" ++ key ++ " " ++ longestCommonPrefix command_options
--    command_options' =
--        if not (null command_options) && head command_options == key
--            then validTerminalCommands key
--            else command_options
--
--    --val' = Debug.Trace.trace key tail val
--    valid_commands = "Options: " ++ intercalate ", " command_options'

getSplitString :: [Char] -> ([Char], [Char])
getSplitString str = case break (== ' ') str of
    (a, _ : b) -> (a, b)
    (a, _) -> (a, "")

isValidCommand :: String -> String -> Bool
isValidCommand arg1 arg2 = arg2 `elem` validTerminalCommands arg1

validTerminalCommands :: String -> [String]
validTerminalCommands "set" = ["hp", "invcap", "invsel", "mass", "mvspeed"]
validTerminalCommands "god" = ["on", "off"]
validTerminalCommands _ = ["set", "spawn", "god"]

loadme :: a
loadme = undefined

longestCommonPrefix :: Eq a => [[a]] -> [a]
longestCommonPrefix [] = []
longestCommonPrefix lists = foldr1 commonPrefix lists

commonPrefix :: Eq a => [a] -> [a] -> [a]
commonPrefix (x : xs) (y : ys)
    | x == y = x : commonPrefix xs ys
commonPrefix _ _ = []