Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: napthats/phivty
base: 6e278d6060
...
head fork: napthats/phivty
compare: 121eaa0ec3
  • 19 commits
  • 6 files changed
  • 0 commit comments
  • 1 contributor
View
46 PhiVty/DB.hs
@@ -6,6 +6,12 @@ module PhiVty.DB (
getRandomInt,
getMessageLog,
setMessageLog,
+ getPrevList,
+ setPrevList,
+ getUIState,
+ setUIState,
+ getCollectionType,
+ setCollectionType,
DB(),
DBData(),
) where
@@ -14,6 +20,7 @@ module PhiVty.DB (
import Control.Monad.ST.Trans
import Control.Monad.State
import System.Random
+import PhiVty.Data.UI
modifySTRef :: Monad m => STRef s a -> (a -> a) -> STT s m ()
@@ -31,7 +38,7 @@ instance (Monad l) => Monad (DB l) where
instance MonadTrans DB where
lift c =
- DB $ \st -> lift c
+ DB $ \_ -> lift c
runDB :: (Monad m) => DBData -> DB m a -> m (a, DBData)
runDB db dbAction = do
@@ -40,7 +47,7 @@ runDB db dbAction = do
result <- internalRunDB dbAction $ context;
next_db <- readSTRef context;
return (result, next_db) }
- let messagelist = reverse $ db_messagelist next_db
+-- let messagelist = reverse $ db_messagelist next_db
let result_db = next_db {db_messagelist = []}
return (result, result_db)
@@ -49,7 +56,10 @@ type DBContext s = STRef s DBData
data DBData = DBData {
db_randomgen :: StdGen,
db_messagelist :: [String],
- db_phimessagelog :: [String]
+ db_phimessagelog :: [String],
+ db_prevphilist :: [String],
+ db_uistate :: UIState,
+ db_collectiontype :: CollectionType
}
getMessageLog :: Monad m => DB m [String]
@@ -60,6 +70,30 @@ setMessageLog :: Monad m => [String] -> DB m ()
setMessageLog mes_list =
DB $ \st -> modifySTRef st (\db_data -> db_data {db_phimessagelog = mes_list})
+getPrevList :: Monad m => DB m [String]
+getPrevList =
+ DB $ \st -> readSTRef st >>= (\x -> return $ db_prevphilist x)
+
+setPrevList :: Monad m => [String] -> DB m ()
+setPrevList mes_list =
+ DB $ \st -> modifySTRef st (\db_data -> db_data {db_prevphilist = mes_list})
+
+getCollectionType :: Monad m => DB m CollectionType
+getCollectionType =
+ DB $ \st -> readSTRef st >>= (\x -> return $ db_collectiontype x)
+
+setCollectionType :: Monad m => CollectionType -> DB m ()
+setCollectionType collectiontype =
+ DB $ \st -> modifySTRef st (\db_data -> db_data {db_collectiontype = collectiontype})
+
+getUIState :: Monad m => DB m UIState
+getUIState =
+ DB $ \st -> readSTRef st >>= (\x -> return $ db_uistate x)
+
+setUIState :: Monad m => UIState -> DB m ()
+setUIState ui_state =
+ DB $ \st -> modifySTRef st (\db_data -> db_data {db_uistate = ui_state})
+
getRandomInt :: Monad m => DB m Int
getRandomInt =
DB $ \st -> do
@@ -72,4 +106,8 @@ initialDB :: Int -> DBData
initialDB random_gen = DBData {
db_randomgen = mkStdGen random_gen,
db_messagelist = [],
- db_phimessagelog = []}
+ db_phimessagelog = [],
+ db_prevphilist = [],
+ db_uistate = UINormal,
+ db_collectiontype = CTNormal
+}
View
8 PhiVty/Data/UI.hs
@@ -0,0 +1,8 @@
+module PhiVty.Data.UI (
+ UIState(..),
+ CollectionType(..),
+ ) where
+
+data UIState = UINormal | UISEdit
+
+data CollectionType = CTNormal | CTMenu
View
42 PhiVty/Protocol.hs
@@ -7,11 +7,16 @@ import Codec.Text.IConv
import Data.ByteString.Lazy.Char8 (pack, unpack)
import Codec.Binary.UTF8.String
import Data.List.Split
+import Data.Bits
+import Data.Char
data ServerProtocol =
- Map (Char, String, String, [((Int, Int), String)])
+ Map (Char, String, [(Int, Int, Int, Int)], [((Int, Int), String)])
| NormalMessage String
| ExNotice (String, String)
+ | PhiList [String]
+ | SEdit
+ | Close
| Unfinished ServerProtocol
| Unknown String
@@ -26,33 +31,46 @@ parse u_mes ('#':protocol) =
let chara_list = case u_mes of
Nothing -> []
Just (Map (_, _, _, l)) -> l
- _ -> error "Invalid server protocol." in
+ _ -> [] in
let (_, map_str) = splitAt 17 protocol in
+ let parseOption op =
+ ((shiftR op 4) .&. 7, (shiftR op 3) .&. 1, (shiftR op 2) .&. 1, op .&. 1) in
let (m, o) = foldl
- (\(chip, op) ord -> (((map_str !! ord) : chip), ((map_str !! (ord + 1)) : op)))
- ("", "")
+ (\(chip, op) od -> (((map_str !! od) : chip), ((parseOption $ ord (map_str !! (od + 1))) : op)))
+ ("", [])
[96, 94..0] in
Unfinished $ Map (protocol !! 6, m, o, chara_list)
'O' ->
let (dir, ma, op, chara_list) = case u_mes of
- Nothing -> (' ', "", "", [])
+ Nothing -> (' ', "", [], [])
Just (Map (d, m, o, l)) -> (d, m, o, l)
- _ -> error "Invalid server protocol." in
- let initial = protocol !! 18 in
+ _ -> (' ', "", [], []) in
+ let initial_raw = protocol !! 18 in
+ let initial = if ord initial_raw > 32 && ord initial_raw < 127 then initial_raw else 'A' in
let x = (read [protocol !! 12] :: Int) in
let y = (read [protocol !! 14] :: Int) in
Unfinished (Map (dir, ma, op, ((x, y), [initial]) : chara_list))
'.' ->
case u_mes of
- Nothing -> error "Invalid server protocol."
- Just x -> x
+ Nothing -> Unknown ""
+ Just (Map x) -> Map x
+ _ -> Unknown ""
_ ->
Unknown protocol
"ex-notice" ->
- let content_list = splitOn "=" $ snd $ splitAt 10 $ decodeString . unpack . convert "SJIS" "UTF-8" . pack $ protocol in
+ let content_list = splitOn "=" $ snd $ splitAt 10 $ phiDecode protocol in
ExNotice (content_list !! 0, content_list !! 1)
+ "list" -> Unfinished $ PhiList []
+ "end-list" -> case u_mes of
+ Nothing -> Unknown ""
+ Just (PhiList x) -> PhiList x
+ _ -> Unknown ""
+ "s-edit" -> SEdit
+ "close" -> Close
_ -> Unknown protocol
+parse (Just (PhiList list)) mes = Unfinished $ PhiList $ list ++ [phiDecode mes]
parse _ mes =
- NormalMessage mes
-
+ NormalMessage $ phiDecode mes
+phiDecode :: String -> String
+phiDecode = decodeString . unpack . convert "SJIS" "UTF-8" . pack
View
51 PhiVty/Socket.hs
@@ -1,4 +1,5 @@
module PhiVty.Socket (
+ initSocket,
connect,
close,
send,
@@ -9,30 +10,56 @@ import Network
import System.IO
import Control.Exception
import Control.Concurrent
-import Prelude hiding (catch)
-data PhiSocket = PhiSocket {internalHandle :: Handle, recvThreadId :: ThreadId}
+data PhiSocket = PhiSocket {hostName :: MVar String, port :: MVar Int, internalHandle :: MVar Handle, recvThreadId :: MVar ThreadId}
-connect :: String -> Int -> (String -> IO ()) -> IO PhiSocket
-connect addr port recv_handler = withSocketsDo $ do
+initSocket :: String -> Int -> IO PhiSocket
+initSocket addr pt = do
+ m_addr <- newMVar addr
+ m_port <- newMVar pt
+ m_handle <- newEmptyMVar
+ m_recv_thread_id <- newEmptyMVar
+ return $ PhiSocket {hostName = m_addr, port = m_port, internalHandle = m_handle, recvThreadId = m_recv_thread_id}
+
+connect :: PhiSocket -> (String -> IO()) -> IO ()
+connect soc recv_handler = do
+ close soc
+ addr <- readMVar $ hostName soc
+ pt <- readMVar $ port soc
hSetBuffering stdout NoBuffering
- h <- connectTo addr (PortNumber $ fromIntegral port)
+ h <- connectTo addr (PortNumber $ fromIntegral pt)
hSetBuffering h LineBuffering
tId <- forkIO $ do
sequence_ $ repeat $ do
+ --have not to be retrieve?
+ --h <- readMVar $ internalHandle soc
res <- hGetLine h
recv_handler res
- `catch` (\(SomeException e) -> return () )
+ `catch` (\(SomeException _) -> return () )
`finally` do
hClose h
- return $ PhiSocket {internalHandle = h, recvThreadId = tId}
+ putMVar (internalHandle soc) h
+ putMVar (recvThreadId soc) tId
+ return ()
close :: PhiSocket -> IO ()
-close soc =
- killThread $ recvThreadId soc
+close soc = do
+ maybe_tid <- tryTakeMVar $ recvThreadId soc
+ _ <- tryTakeMVar $ internalHandle soc
+ case maybe_tid of
+ Nothing -> return ()
+ Just tid -> do
+ killThread tid
+-- _ <- takeMVar (internalHandle soc)
+ return ()
send :: String -> PhiSocket -> IO ()
-send mes soc =
- hPutStrLn (internalHandle soc) mes
- `catch` (\(SomeException e) -> return ())
+send mes soc = do
+ maybe_handle <- tryTakeMVar $ internalHandle soc
+ case maybe_handle of
+ Nothing -> return ()
+ Just internal_handle ->
+ hPutStrLn internal_handle mes
+ `catch` (\(SomeException _) -> return ())
+ `finally` putMVar (internalHandle soc) internal_handle
View
310 PhiVty/UI.hs
@@ -1,16 +1,10 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module PhiVty.UI
(
UIData,
initialPhiUI,
runPhiUI,
- setMap,
- setDirection,
- setLandName,
- setAreaName,
- setMapTitle,
- setMessage,
- addMessage,
- parsePhiTags,
) where
import Graphics.Vty.Widgets.All
@@ -18,102 +12,297 @@ import qualified Data.Text as T
import Graphics.Vty.LLInput
import Graphics.Vty.Attributes
import PhiVty.Socket
+import PhiVty.Protocol
import PhiVty.DB
import PhiVty.Cdo
-import Data.List
import Data.List.Split
import Control.Monad.Trans
import Data.IORef
import Text.Regex
+import PhiVty.Data.UI
+import Control.Concurrent
--import Control.Concurrent
-data UIData = UIData {
- ui_collection :: Collection,
+data UIDataInternal = UIDataInternal {
ui_maptext :: Widget FormattedText,
ui_message :: Widget FormattedText,
ui_maptitle :: Widget FormattedText,
v_maptitle :: IORef (String, String, String)
}
+type UIData = Collection
inputHandler :: PhiSocket -> String -> IO ()
inputHandler soc mes =
if mes == ":exit" then error "exit" else send mes soc
-mapHandler :: (Monad m) => PhiSocket -> Key -> [Modifier] -> Cdo (DB m ()) -> IO ()
-mapHandler soc key modList cdod =
+mapHandler :: PhiSocket -> Key -> [Modifier] -> Cdo (DB IO ()) -> (CollectionType -> IO()) -> IO ()
+mapHandler soc key mod_list c change_ct = cdo c $ do
+ ui_state <- getUIState
+ lift $ _mapHandler ui_state soc key mod_list c change_ct
+ setUIState UINormal
+
+_mapHandler :: UIState -> PhiSocket -> Key -> [Modifier] -> Cdo (DB IO ()) -> (CollectionType -> IO()) -> IO ()
+_mapHandler UINormal soc key [] _ _ =
case key of
- KASCII '1' -> send "hit" soc
- KASCII '2' -> send "go b" soc
- KASCII '3' -> send "cast" soc
- KASCII '4' -> send "go l" soc
- KASCII '5' -> send "turn b" soc
- KASCII '6' -> send "go r" soc
- KASCII '7' -> send "turn l" soc
- KASCII '8' -> send "go" soc
- KASCII '9' -> send "turn r" soc
- KASCII '0' -> do {send "look" soc; send "check" soc}
+ KEnd -> send "hit" soc
+ KDown -> send "go b" soc
+ KPageDown -> send "cast" soc
+ KLeft -> send "go l" soc
+ KBegin -> send "turn b" soc
+ KRight -> send "go r" soc
+ KHome -> send "turn l" soc
+ KUp -> send "go" soc
+ KPageUp -> send "turn r" soc
+ KIns -> do {send "look" soc; send "check" soc}
+ KDel -> send "." soc
KASCII '.' -> send "." soc
- KASCII c -> do
- cdo cdod $ do
- old_mes_list <- getMessageLog
- let new_mes_list = (":Input " ++ [c]) : old_mes_list
- setMessageLog new_mes_list
- _ -> error "????"
-
-initialPhiUI :: (Monad m) => PhiSocket -> Cdo (DB m ()) -> IO UIData
-initialPhiUI soc cdod = do
+ KASCII '1' -> send "1" soc
+ KASCII '2' -> send "2" soc
+ KASCII '3' -> send "3" soc
+ KASCII '4' -> send "4" soc
+ KASCII '5' -> send "5" soc
+ KASCII '6' -> send "6" soc
+ KASCII '7' -> send "7" soc
+ KASCII '8' -> send "8" soc
+ KASCII '9' -> send "9" soc
+ KASCII '0' -> send "0" soc
+ KASCII 'z' -> send "get" soc
+ KASCII 'c' -> send "use" soc
+ KASCII 'x' -> send "put" soc
+ KASCII 'q' -> send "equip" soc
+ KASCII 'w' -> send "unequip" soc
+ KASCII 'v' -> send "sort" soc
+ KASCII 'a' -> send "read" soc
+ KASCII 's' -> send "write" soc
+ KASCII 'f' -> send "floor item" soc
+ KASCII 'b' -> send "board" soc
+ KASCII 'd' -> send "erace" soc
+ KASCII 'g' -> send "guard" soc
+ KASCII 'h' -> send "hi" soc
+ KASCII 'y' -> send "y" soc
+ KASCII _ -> return ()
+ _ -> return ()
+_mapHandler UINormal soc key mod_list c change_ct =
+ if elem MMeta mod_list || elem MAlt mod_list
+ then case key of
+ KASCII 'w' -> do {send "cast" soc; send "wizard eye" soc}
+ KASCII 'e' -> do {send "cast" soc; send "eagle eye" soc}
+ KASCII 'a' -> do {send "cast" soc; send "analyze" soc}
+ KASCII 'c' -> do {send "cast" soc; send "create" soc}
+ KASCII 'i' -> do {send "cast" soc; send "identify" soc}
+ KASCII 'l' -> do {send "cast" soc; send "wizard lock" soc}
+ KASCII 'u' -> do {send "cast" soc; send "unlock" soc}
+ KASCII 's' -> do {send "cast" soc; send "search" soc}
+ KASCII 'm' -> cdo c $ do
+ ct <- getCollectionType
+ case ct of
+ CTNormal -> do {lift $ schedule $ change_ct CTMenu; setCollectionType CTMenu}
+ CTMenu -> do {lift $ schedule $ change_ct CTNormal; setCollectionType CTNormal}
+ KASCII _ -> return ()
+ _ -> return ()
+ else return ()
+_mapHandler UISEdit soc key [] c change_ct = cdo c $ do
+ prev_philist <- getPrevList
+ let first_ord = getFirstOrd prev_philist
+ lift $ do {case key of
+ KASCII '1' -> send (show first_ord) soc
+ KASCII '2' -> send (show $ first_ord + 1) soc
+ KASCII '3' -> send (show $ first_ord + 2) soc
+ KASCII '4' -> send (show $ first_ord + 3) soc
+ KASCII '5' -> send (show $ first_ord + 4) soc
+ KASCII '6' -> send (show $ first_ord + 5) soc
+ KASCII '7' -> send (show $ first_ord + 6) soc
+ KASCII '8' -> send (show $ first_ord + 7) soc
+ KASCII '9' -> send (show $ first_ord + 8) soc
+ _ -> _mapHandler UINormal soc key [] c change_ct}
+ return ()
+ where getFirstOrd philist =
+ case philist of
+ [] -> 1
+ fst_elem : _ ->
+ (read (dropWhile (\x -> x == '[' || x == ' ') $ takeWhile ((/=) ']') fst_elem) :: Int)
+_mapHandler UISEdit soc key mod_list c change_ct = _mapHandler UINormal soc key mod_list c change_ct
+
+makeWindowWithChara :: MultiStringListData -> Cdo (DB IO ()) -> String -> String -> Int -> Collection -> IO (IO ())
+makeWindowWithChara menu_item c chara_id host_name port_num collection = do
+ v_m <- newIORef ("", "", "")
+ titletest <- plainText " "
+ maptext <- plainText (T.pack $ makeMapString initialMapList initialMapOptionList [((3, 3), "m")])
+ mes_plain <- plainText " "
+ let uidata = UIDataInternal {v_maptitle = v_m, ui_maptitle = titletest, ui_maptext = maptext, ui_message = mes_plain}
+ soc <- initSocket host_name port_num
+
e <- editWidget
-- tentative
e `onActivate` \this -> do
txt <- getEditText this
inputHandler soc $ T.unpack txt
- setEditText this $ T.pack ""
- mes_plain <- plainText (T.pack "hi")
- mes <- centered mes_plain
- titletest <- plainText (T.pack " ")
+ setEditText this ""
+ let mes = mes_plain
title <- hCentered titletest
- maptext <- plainText (T.pack $ makeMapString initialMapList [((3, 3), "m")])
- maptext `onKeyPressed` \_ key mod_list -> do {mapHandler soc key mod_list cdod; return True}
mp <- bordered maptext >>= hCentered
- main_box <- (((return title <--> return mp) >>= centered) <++> return mes) <--> (return e)
+
+ connect_action_mvar <- newEmptyMVar
+ let menu_item_innner = case menu_item of MultiStringListData list -> list
+ menu <- makeMultiStringList $ MultiStringListData $ menu_item_innner ++ [
+ ("Connect", Left $ do {action <- readMVar connect_action_mvar; action}),
+ ("Disconnect", Left $ send "exit" soc)]
+ upper_left_box_wmenu <- centered menu <--> ((return title <--> return mp) >>= centered)
+ setBoxChildSizePolicy upper_left_box_wmenu $ Percentage 50
+ upper_box_wmenu <- (return upper_left_box_wmenu <++> return mes)
+ setBoxChildSizePolicy upper_box_wmenu $ Percentage 40
+ main_box_wmenu <- (return upper_box_wmenu) <--> (return e)
+ fg_wmenu <- newFocusGroup
+ _ <- addToFocusGroup fg_wmenu e
+ _ <- addToFocusGroup fg_wmenu maptext
+ _ <- addToFocusGroup fg_wmenu menu
+
+ upper_box <- (((return title <--> return mp) >>= centered) <++> return mes)
+ setBoxChildSizePolicy upper_box $ Percentage 40
+ main_box <- (return upper_box) <--> (return e)
fg <- newFocusGroup
_ <- addToFocusGroup fg e
_ <- addToFocusGroup fg maptext
- c <- newCollection
- _ <- addToCollection c main_box fg
- v_m <- newIORef ("", "", "")
- return $ UIData {v_maptitle = v_m, ui_collection = c, ui_maptitle = titletest, ui_maptext = maptext, ui_message = mes_plain}
+ ct_menu <- addToCollection collection main_box_wmenu fg_wmenu
+ ct_normal <- addToCollection collection main_box fg
+ let change_collection_type ct =
+ case ct of
+ CTNormal -> ct_normal
+ CTMenu -> ct_menu
+ maptext `onKeyPressed` \_ key mod_list -> do {mapHandler soc key mod_list c change_collection_type; return True}
+ m_u_mes <- newMVar Nothing
+ let recv_handler new_mes = do
+ u_mes <- takeMVar m_u_mes
+ putMVar m_u_mes Nothing
+ do {case parse u_mes new_mes of
+ NormalMessage n_mes -> do
+ addMessage uidata c n_mes
+ Map (m_dir, m_chip_string, m_op_string, chara_list) -> do
+ setMap uidata m_chip_string m_op_string chara_list
+ setDirection uidata [m_dir]
+ ExNotice (key, value) ->
+ case key of
+ "land" -> do
+ setLandName uidata value
+ "area" -> do
+ setAreaName uidata value
+ _ -> return ()
+ PhiList list -> cdo c $ do
+ setPrevList list
+ lift $ mapM_ (addMessage uidata c) $ "---------------" :
+ snd (foldl (\(ord, acc) elm -> (ord+1, (acc ++ [("(" ++ show ord ++ ")" ++ elm)]))) (1 :: Integer, []) list) ++ ["---------------"]
+ SEdit -> cdo c $ do
+ setUIState UISEdit
+ Close -> close soc
+ Unfinished u -> modifyMVar_ m_u_mes $ const $ return $ Just u
+ Unknown "" -> return ()
+ Unknown un_mes -> do
+ addMessage uidata c $ '#' : un_mes
+ }
+ return ()
+ putMVar connect_action_mvar $ do {
+ connect soc recv_handler;
+ send ("#open " ++ chara_id) soc;
+ send "#map-iv 1" soc;
+ send "#status-iv 1" soc;
+ send "#version-cli 05103010" soc;
+ send "#ex-switch eagleeye=form" soc;
+ send "#ex-map size=57" soc;
+ send "#ex-map style=turn" soc;
+ send "#ex-switch ex-move-recv=true" soc;
+ send "#ex-switch ex-list-mode-end=true" soc;
+ send "#ex-switch ex-disp-magic=false" soc
+ }
+ return ct_menu
+
+
+initialPhiUI :: Cdo (DB IO ()) -> [(String, String, Int)] -> IO UIData
+initialPhiUI cdod chara_list = do
+ (action_mvar_list, multi_string_list_data) <- createMultiStringListData chara_list
+ collection <- newCollection
+ ct_menu_action_list <- mapM (\(chara_id, host_name, port_num) -> makeWindowWithChara multi_string_list_data cdod chara_id host_name port_num collection) chara_list
+ mapM_ (\(action_mvar, ct_menu_action) -> putMVar action_mvar ct_menu_action) (zip action_mvar_list ct_menu_action_list)
+ return collection
+
+data MultiStringListData = MultiStringListData [(String, Either (IO ()) MultiStringListData)]
+
+createMultiStringListData :: [(String, String, Int)] -> IO([MVar (IO ())], MultiStringListData)
+createMultiStringListData chara_list = do
+ action_mvar_list <- mapM (\_ -> newEmptyMVar) chara_list
+ let msld =
+ [("Load charactor", Right $ MultiStringListData $
+ map (\((name, _, _), action_mvar) -> (name, Left $ do{action <- readMVar action_mvar; action})) (zip chara_list action_mvar_list))]
+ return $ (action_mvar_list, MultiStringListData msld)
+
+-- Names of data must not be duplicated
+-- All spaces at head of names will be deleted
+makeMultiStringList :: MultiStringListData -> IO (Widget (List T.Text FormattedText))
+makeMultiStringList (MultiStringListData msl_data) = do
+ vty_list <- newTextList def_attr $ map (T.pack . removeSpace . fst) msl_data
+ vty_list `onItemActivated` \(ActivateItemEvent ord name _) ->
+ case getData msl_data (T.unpack name) of
+ Left io -> io
+ Right (MultiStringListData inner_data) -> do
+ maybe_next_item <- getListItem vty_list $ ord + 1
+ mapM_ (\(inner_name, _) ->
+ do
+ let level t_name = length (T.unpack t_name) - length (dropWhile ((==) ' ') (T.unpack t_name))
+ inner_widget <- plainText $ T.pack $ (replicate (level name + 1) ' ') ++ inner_name
+ let expand_list = insertIntoList vty_list (T.pack $ replicate (level name + 1) ' ' ++ inner_name) inner_widget (ord + 1)
+ let collaps_list = do{_ <- removeFromList vty_list (ord + 1); return ()}
+ case maybe_next_item of
+ Nothing -> expand_list
+ Just (next_name, _) ->
+ if level name >= level next_name
+ then expand_list
+ else collaps_list
+ ) (reverse inner_data)
+ return vty_list
+ where removeSpace str = dropWhile ((==) ' ') str
+ getData _x __name =
+ let _getData x _name =
+ case x of
+ [] -> error "Assertion Error: makeMultiStringList cannot find data."
+ (x_name, x_data) : rem_data ->
+ if x_name == _name
+ then x_data
+ else case x_data of
+ Left _ -> _getData rem_data _name
+ Right (MultiStringListData inner_data) ->
+ _getData (inner_data ++ rem_data) _name
+ in
+ _getData _x $ removeSpace __name
runPhiUI :: UIData -> IO ()
-runPhiUI uidata = runUi (ui_collection uidata) defaultContext
+runPhiUI uidata = runUi uidata defaultContext
-setMap :: UIData -> String -> [((Int, Int), String)] -> IO ()
-setMap uidata str chara_list =
- schedule $ setText (ui_maptext uidata) (T.pack $ makeMapString str chara_list)
+setMap :: UIDataInternal -> String -> [(Int, Int,Int, Int)] -> [((Int, Int), String)] -> IO ()
+setMap uidata str op_list chara_list =
+ schedule $ setText (ui_maptext uidata) (T.pack $ makeMapString str op_list chara_list)
-setMapTitle :: UIData -> String -> IO ()
+setMapTitle :: UIDataInternal -> String -> IO ()
setMapTitle uidata mes =
schedule $ setText (ui_maptitle uidata) (T.pack $ mes)
-setDirection :: UIData -> String -> IO ()
+setDirection :: UIDataInternal -> String -> IO ()
setDirection uidata dir = do
(_, land, area) <- readIORef $ v_maptitle uidata
setMapTitle uidata $ "[" ++ dir ++ "]" ++ land ++ "(" ++ area ++ ")"
writeIORef (v_maptitle uidata) (dir, land, area)
-setLandName :: UIData -> String -> IO ()
+setLandName :: UIDataInternal -> String -> IO ()
setLandName uidata land = do
(dir, _, area) <- readIORef $ v_maptitle uidata
setMapTitle uidata $ "[" ++ dir ++ "]" ++ land ++ "(" ++ area ++ ")"
writeIORef (v_maptitle uidata) (dir, land, area)
-setAreaName :: UIData -> String -> IO ()
+setAreaName :: UIDataInternal -> String -> IO ()
setAreaName uidata area = do
(dir, land, _) <- readIORef $ v_maptitle uidata
setMapTitle uidata $ "[" ++ dir ++ "]" ++ land ++ "(" ++ area ++ ")"
writeIORef (v_maptitle uidata) (dir, land, area)
-setMessage :: UIData -> [String] -> IO ()
+setMessage :: UIDataInternal -> [String] -> IO ()
setMessage uidata str_list = do
-- schedule $ setText (ui_message uidata) (T.pack $ intercalate "\n" $ str_list)
schedule $ setTextWithAttrs (ui_message uidata) (concatMap parsePhiTags str_list)
@@ -121,7 +310,7 @@ setMessage uidata str_list = do
parsePhiTags :: String -> [(T.Text, Attr)]
parsePhiTags str = _parse def_attr str
- where _parse attr str =
+ where _parse attr _str =
let tag2Attr tag =
case splitOn "=" (drop 2 $ take (length tag - 2) tag) of
["color", color] ->
@@ -142,13 +331,13 @@ parsePhiTags str = _parse def_attr str
_ -> def_attr
_ -> def_attr
in
- case matchRegexAll (mkRegex "/[*][^*]*[*]/") str of
- Nothing -> [(T.pack (str ++ "\n"), attr)]
+ case matchRegexAll (mkRegex "/[*][^*]*[*]/") _str of
+ Nothing -> [(T.pack (_str ++ "\n"), attr)]
Just (before_str, tag, after_str, _) -> (T.pack before_str, attr) : (_parse (tag2Attr tag) after_str)
-addMessage :: UIData -> (Cdo (DB IO ())) -> String -> IO ()
+addMessage :: UIDataInternal -> (Cdo (DB IO ())) -> String -> IO ()
addMessage uidata c mes = cdo c $ do
old_mes_list <- getMessageLog
let new_mes_list = mes : old_mes_list
@@ -158,18 +347,21 @@ addMessage uidata c mes = cdo c $ do
initialMapList :: String
initialMapList = "????????>% o=??#|{I@?? H??_T:+/??_:::H????????"
+initialMapOptionList :: [(Int, Int, Int, Int)]
+initialMapOptionList = replicate 49 (0,0,0,0)
+
mapSize :: Int
mapSize = 7
-makeMapString :: String -> [((Int, Int), String)] -> String
-makeMapString map_list chara_list =
+makeMapString :: String -> [(Int, Int, Int, Int)] -> [((Int, Int), String)] -> String
+makeMapString map_list op_list chara_list =
let get_chara (x, y) default_chip ord list =
let filtered_list = (filter (\((xx, yy), _) -> x == xx && y == yy)) list in
if ord >= 0 && ord < length filtered_list
then snd $ filtered_list !! ord
else default_chip
in
- fst $ foldl (\(str, (hord, vord)) chr -> let [fchip, schip] = mapChipToString chr in ((str ++ get_chara (hord, vord) [fchip] 0 chara_list ++ get_chara (hord, vord) [schip] 1 chara_list ++ if hord == mapSize - 1 then "\n" else ""), if hord == mapSize - 1 then (0, vord+1) else (hord + 1, vord))) ("", (0, 0)) map_list
+ fst $ foldl (\(str, (hord, vord)) (chr, (i_type, m_flag, _, _)) -> let [fchip, schip] = mapChipToString chr in let schip_or_im = if m_flag > 0 then 't' else if i_type > 0 then 'o' else schip in ((str ++ get_chara (hord, vord) [fchip] 0 chara_list ++ get_chara (hord, vord) [schip_or_im] 1 chara_list ++ if hord == mapSize - 1 then "\n" else ""), if hord == mapSize - 1 then (0, vord+1) else (hord + 1, vord))) ("", (0, 0)) (zip map_list op_list)
mapChipToString :: Char -> String
mapChipToString p =
View
62 main.hs
@@ -1,17 +1,7 @@
import PhiVty.UI
import PhiVty.DB
-import PhiVty.Socket
-import PhiVty.Protocol
import Control.Concurrent
-import Control.Monad.Trans
-import Control.Concurrent.STM.TChan
-import Control.Concurrent.STM
-import Data.List
-import Codec.Text.IConv
-import Data.ByteString.Lazy.Char8 (pack, unpack)
-import Codec.Binary.UTF8.String
import PhiVty.Cdo
-import Data.Char
import System.Environment
@@ -21,64 +11,14 @@ main = do
if length args /= 3 then error "main ip port id" else do
let new_dbdata = initialDB 0
c <- newCdo
- tchan <- atomically newTChan
- let recv_handler mes =
--- atomically $ writeTChan tchan (decodeString . unpack . convert "SJIS" "UTF-8" . pack $ mes)
- atomically $ writeTChan tchan mes
- --soc <- connect "49.212.144.158" 20017 recv_handler
- soc <- connect (args !! 0) (read (args !! 1) :: Int) recv_handler
- uidata <- initialPhiUI soc c
+ uidata <- initialPhiUI c [("guest4", (args !! 0), (read (args !!1) :: Int)), ((args !! 2), (args !! 0), (read (args !! 1) :: Int))]
_ <- forkIO $ do
let loop dbdata = do
m <- getMonad c
(_, next_dbdata) <- runDB dbdata $ do
_ <- m
return ()
--- mes_list <- getMessageLog
--- lift $ setMessage uidata $ intercalate "\n" $ reverse mes_list
threadDelay 100000
loop next_dbdata
loop new_dbdata
- _ <- forkIO $ do
--- send "#open guest3" soc
- send ("#open " ++ (args !! 2)) soc
- send "#map-iv 1" soc
- send "#status-iv 1" soc
- send "#version-cli 05103010" soc
- send "#ex-switch eagleeye=form" soc
- send "#ex-map size=57" soc
- send "#ex-map style=turn" soc
- send "#ex-switch ex-move-recv=true" soc
- send "#ex-switch ex-list-mode-end=true" soc
- send "#ex-switch ex-disp-magic=false" soc
- let loop u_mes = do
- new_mes <- atomically $ readTChan tchan
- case parse u_mes new_mes of
- NormalMessage n_mes_raw -> do
- let n_mes = decodeString . unpack . convert "SJIS" "UTF-8" . pack $ n_mes_raw
- addMessage uidata c n_mes
- loop Nothing
- Map (m_dir, m_chip_string, m_op_string, chara_list) -> do
- setMap uidata m_chip_string chara_list
- setDirection uidata [m_dir]
--- cdo c $ do
--- old_mes_list <- getMessageLog
--- let new_mes_list = (concat (map show (map ord m_op_string))) : old_mes_list
--- lift $ setMessage uidata $ intercalate "\n" $ reverse new_mes_list
--- setMessageLog new_mes_list
- loop Nothing
- Unfinished u -> loop $ Just u
- ExNotice (key, value) ->
- case key of
- "land" -> do
- setLandName uidata value
- loop Nothing
- "area" -> do
- setAreaName uidata value
- loop Nothing
- _ -> loop Nothing
- Unknown mes -> do
- addMessage uidata c $ '#' : mes
- loop Nothing
- loop Nothing
runPhiUI uidata

No commit comments for this range

Something went wrong with that request. Please try again.