~vonfry/lift-dfa

8385a869a1e07b87517830bbd7c9559df25603c3 — Vonfry 2 years ago 889ca69
test & main loop
4 files changed, 271 insertions(+), 18 deletions(-)

M app/Main.hs
M doc/report.tex
M lib/Scheduler/TaskQueue.hs
M readme.org
M app/Main.hs => app/Main.hs +88 -11
@@ 1,10 1,20 @@
{-# LANGUAGE MultiWayIf #-}

module Main where

import Floor
import Scheduler
import Scheduler.TaskQueue
import Lift
import Control.Concurrent (threadDelay)

import Data.List ( elem
                 , dropWhileEnd
                 , subsequences
                 )
import Data.Char ( isSpace
                 , toLower
                 )
import Data.Char (isSpace)
import Options.Applicative

newtype Arguments = Arguments


@@ 32,17 42,84 @@ main = mainDefault =<< execParser opts
mainDefault :: Arguments -> IO ()
mainDefault args = do
    putStrLn $ "Your floors: " ++ show floors
    -- TODO get scheduler initialzation
    -- TODO loop or manage task queen
    -- TODO print task result
    mainLoop lift
  where
    floors :: FloorName
    floors = parseFloor $ floorsName args
    parseFloor = map trim . splitOneOf ", "
    splitOneOf s =
      foldr (\a b'@(b:bs) ->
                if a `elem` s
                  then "":b'
                  else (a : b) : bs
            ) [""]
    trim = dropWhileEnd isSpace . dropWhile isSpace
    lift = initLift { floorNames = floors }

mainLoop :: Lift -> IO ()
mainLoop lift = loop $ Right (lift, emptyTask)
  where
    loop :: Either String (Lift, TaskQueue) -> IO ()
    loop (Right (lift, tasks)) = do
        putStrLn "\n------"
        tasksIn <- getTask
        parseTaskin tasksIn lift tasks
    loop (Left msg) = putStrLn msg

    -- | This subfunction is the main state machine.
    -- This struct is not good. We should move this part into 'M.Lift'.
    -- And code a parse convert input string to special data for state
    -- machine input
    parseTaskin :: [String] -> Lift -> TaskQueue -> IO ()
    parseTaskin ["open"]   lift@(Lift _ (LiftMove _) _) tasks =
        parseTaskin ["_"] lift tasks
    parseTaskin ["close"]  lift@(Lift _ (LiftMove _) _) tasks =
        parseTaskin ["_"] lift tasks
    parseTaskin ["open"]  lift tasks = do
        putStrLn "Open"
        let lift' = onOpen lift
        threadDelay delayTime
        parseTaskin ["close"] lift' tasks
    parseTaskin ["close"] lift tasks  = do
        putStrLn "Close"
        let lift' = onClose lift
        threadDelay delayTime
        loop $ Right (lift', tasks)
    parseTaskin ["stop"] _ _ = loop $ Left "Stop"
    parseTaskin ["exception"] _ _ = loop $ Left "Exception"
    parseTaskin ["_"] _ Empty = loop $ Left "Finish"
    parseTaskin ["_"] lift tasks = do
        let (task, tasks') = popTask tasks lift
        putStrLn "do task"
        putStrLn $ "Current floor: " ++ show (floorNames lift !! curFloor lift)
        putStrLn $ "MoveTo: " ++ show (floorNames lift !! task)
        case doTask task lift of
            Left lift' -> parseTaskin ["open"] lift' tasks'
            Right (fl', lift') -> do
                threadDelay delayTime
                loop $ Right (lift', pushTask tasks' fl')
    parseTaskin taskin lift tasks =
        let tasks' = foldr (flip onFloor lift) tasks taskin
        in parseTaskin ["_"] lift tasks'

    delayTime = 5 * 10 ^ 5

getTask :: IO [String]
getTask = do
    putStrLn "Input tasks(floor name/(c)lose/(o)pen//(s)top/(e)xception)/[_]:"
    t <- getLine
    if | elem t ["_", ""]   -> return ["_"]
       | isT t "close"      -> return ["close"]
       | isT t "open"       -> return ["open"]
       | isT t "stop"       -> return ["stop"]
       | isT t "exception"  -> return ["exception"]
       | otherwise    -> return $ parseTasks t
  where
    parseTasks :: String -> [String]
    parseTasks = map trim . splitOneOf ", "
    isT :: String -> String -> Bool
    isT t = elem (toLower <$> t) . subsequences

-- * help function

splitOneOf s =
    foldr (\a b'@(b:bs) ->
            if a `elem` s
                then "":b'
                else (a : b) : bs
        ) [""]

trim = dropWhileEnd isSpace . dropWhile isSpace

M doc/report.tex => doc/report.tex +171 -7
@@ 36,7 36,8 @@
\usepackage{verbatim}
\usepackage{listings}
\lstset{
  float,
  float=H,
  breaklines=true,
  basicstyle=\ttfamily,
  mathescape=true,
  numbers=left,


@@ 116,7 117,7 @@
\chapter{设计说明}
在引言中,说明了问题及与之相关的两个主要元素。本章根据上述描述设计模拟程序。

\section{问题分析}
\section{问题分析}\label{sec:dfa}
电梯运行可以分解为两个子状态机,分别为运行状态和楼层状态。两组状态分别管理着不同的部分,共同运作使得电梯正常工作。

在实际开发过程中,将二者聚合为一个结构(状态集合),使代码结构更加易读。


@@ 213,6 214,12 @@ CLI
  \caption{\label{fig:module}系统模块}
\end{figure}

输入输出负责必要的参数。根据运行结果打印相应的值。在正常的电梯程序中,输出应为控制信号以及显示在电梯内外屏幕或者按钮指示灯亮起。但这里只是一个模拟程序,以打印字符为基准。

调试模块管理任务队列和状态转换。在输入输出中将参数交由任务队列,并控制调试器根据任务队列的值进行相应的操作。

状态转换模块即本程序的核心,以DFA来管理电梯的运行状态。其分析见\ref{sec:dfa}。

\section{模块设计}

\subsection{输入输出}\label{subsec:io}


@@ 220,18 227,46 @@ CLI

输入参数设计结构如\ref{lst:arguments}。

\begin{lstlisting}[float,label=lst:arguments,caption=参数结构]
\begin{lstlisting}[language=Haskell,label=lst:arguments,caption=参数结构]
newtype Arguments = Arguments
  { floorsName :: String -- ^ a list of string for floors name, which are splited
                         -- by "," or spaces . Its count is used to create state mathine
  }
\end{lstlisting}

使用库\verb~optparse-applicative~,通过应用函子定义参数解析器,由IO单子调用完成参数的解析。

除参数外,输入输出模块还管理计算结果的输出,如电子控制信号的发送,以及等待执行元件返回工部的信号。这里模拟程序以此化简。以打印楼层名和相关执行动作来描绘运作工况。同时,以主循环每次循问输入的方法来获取输入的任务。同时,以进程的睡眠(0.5s)来模拟执行元件的运行时间。为了简化设计,不使用多线程管理主循环。

接收参数后,初始化各子模块,启动主循环。在主循环中,每一个循环内进行任务的输入、任务列表的检查、下一任务的执行等。

\subsection{调度模块}
调度模块包含一个任务队列,根据当前的楼层状态选取状态变更的操作,调用状态转换模块中的转移函数完成状态的转移。

其主要包含如\ref{lst:call}。调度模块与IO操作完全分离,如\ref{subsec{io}}所述,此模块不包含循环控制等功能。需要由IO模块进行实现并调用的主调度函数。

\begin{lstlisting}[label=lst:call,caption=调度函数]
\begin{lstlisting}[language=Haskell,label=lst:call,caption=调度函数]
onFloor :: String -> Lift -> TaskQueue -> TaskQueue

doTask :: LiftFloor
       -> Lift
       -> Either Lift (LiftFloor, Lift)  

doFloorUp :: Lift -> Lift

doFloorDown :: Lift -> Lift

onOpen :: Lift -> Lift

onClose :: Lift -> Lift

doIdle :: Lift -> Lift

doLoad :: Lift -> Lift

onExcept :: Lift -> Lift

doExcept :: Lift -> Lift
\end{lstlisting}

\subsection{状态转换模块}


@@ 240,14 275,48 @@ CLI

首先我们需要先定义状态结构,一共包含两个,分别为楼层状态与执行状态,由于结构简单,使用\verb~newtype~进行语法层面的打包,在运行期不会产生额外的打包与解包。其具体结构如\ref{lst:state}

\begin{lstlisting}[label=lst:state,caption=状态结构]

\begin{lstlisting}[language=Haskell,label=lst:state,caption=状态结构]
type LiftFloor = Int

data LiftState = LiftIdle
               | LiftMove LiftMoveT
               | LiftLoad
               | LiftException
               deriving (Eq, Show, Read)

data LiftMoveT = LiftMoveUp | LiftMoveDown
    deriving (Eq, Show, Read)

caseMoveT :: f           -- ^ return if Up
          -> f           -- ^ return if Down
          -> LiftMoveT
          -> f
caseMoveT a _ LiftMoveUp   = a
caseMoveT _ b LiftMoveDown = b

data Lift = Lift { curFloor   :: LiftFloor
                 , curState   :: LiftState
                 , floorNames :: FloorName
                 }
            deriving (Eq, Show, Read)
\end{lstlisting}

根据需求,定义如\ref{lst:state-trans}的转移函数,具体实现此处略去。

\begin{lstlisting}[label=lst:state-trans,caption=转移函数]
\begin{lstlisting}[language=Haskell,label=lst:state-trans,caption=转移函数]
moveLUp :: State Lift LiftFloor

moveLDown :: State Lift LiftFloor

idleS :: State Lift LiftFloor

loadS :: State Lift LiftFloor

exceptS :: State Lift LiftFloor

moveSUp :: State Lift LiftFloor

moveSDown :: State Lift LiftFloor
\end{lstlisting}

\chapter{使用说明}


@@ 277,10 346,105 @@ CLI

\subsection{CLI参数}
\begin{lstlisting}[label=lst:cli-args,caption=cli参数]
Lift simulator.

Usage: lift [LIST]
  Lift simulator by DFA for my homework.

Available options:
  LIST                     a list of strting for floors name, which are splited
                           by , or space. (default: "B1,F0,F1,F2,F3,F4")
  -h,--help                Show this help text
\end{lstlisting}

\subsection{运行实例}
\begin{lstlisting}[label=lst:instance,caption=运行样例]
Your floors: ["B1","F0","F1","F2","F3","F4"]

------
Input tasks(floor name/(c)lose/(o)pen//(s)top/(e)xception)/[_]:
F4,F2,F1,B1,F4
do task
Current floor: "B1"
MoveTo: "B1"
Open
Close

------
Input tasks(floor name/(c)lose/(o)pen//(s)top/(e)xception)/[_]:

do task
Current floor: "B1"
MoveTo: "F1"

------
Input tasks(floor name/(c)lose/(o)pen//(s)top/(e)xception)/[_]:

do task
Current floor: "F0"
MoveTo: "F1"

------
Input tasks(floor name/(c)lose/(o)pen//(s)top/(e)xception)/[_]:

do task
Current floor: "F1"
MoveTo: "F1"
Open
Close

------
Input tasks(floor name/(c)lose/(o)pen//(s)top/(e)xception)/[_]:

do task
Current floor: "F1"
MoveTo: "F2"

------
Input tasks(floor name/(c)lose/(o)pen//(s)top/(e)xception)/[_]:

do task
Current floor: "F2"
MoveTo: "F2"
Open
Close

------
Input tasks(floor name/(c)lose/(o)pen//(s)top/(e)xception)/[_]:

do task
Current floor: "F2"
MoveTo: "F4"

------
Input tasks(floor name/(c)lose/(o)pen//(s)top/(e)xception)/[_]:

do task
Current floor: "F3"
MoveTo: "F4"

------
Input tasks(floor name/(c)lose/(o)pen//(s)top/(e)xception)/[_]:

do task
Current floor: "F4"
MoveTo: "F4"
Open
Close

------
Input tasks(floor name/(c)lose/(o)pen//(s)top/(e)xception)/[_]:

do task
Current floor: "F4"
MoveTo: "F4"
Open
Close

------
Input tasks(floor name/(c)lose/(o)pen//(s)top/(e)xception)/[_]:

Finish
\end{lstlisting}

\end{document}

M lib/Scheduler/TaskQueue.hs => lib/Scheduler/TaskQueue.hs +1 -0
@@ 23,6 23,7 @@ popTask :: TaskQueue                -- ^ current task queue
        -> (LiftFloor, TaskQueue)   -- ^ @(next-floor, rest-queue)@
popTask t c = pop $ sortOn (sortTask c) t
  where
    pop Empty = (curFloor c, t)
    pop (x :<| xs) = (x, xs)

-- | Push a new task into the queue

M readme.org => readme.org +11 -0
@@ 4,6 4,17 @@ A homework to code program to solve lift problem by dfa.

More detail please see [[doc][./doc]].


** *Notice*

The subfunction in main loop named ~parseTaskin~ is the main state machine.
This struct is not good. We should move this part into 'M.Lift'.
And code a parse convert input string to special data for state
machine input.

But this project is just for my project and it is enough for me to commit it, so
I won't modify this part any more.

** Build

~cabal build~ or ~nix build~