model.hs

import System.IO
import Data.Char (toLower)

process :: (Int, Int) -> [Int] -> [[Int]]
process  (m, k) tasks  = tasks : (process' (m, k) tasks)
process' (m, k) []    = []
process' (m, k) tasks = processed : (process' (m, k) processed) where processed = (drop m tasks) ++ (filter (>0) $ map (subtract k) (take m tasks))

showProcessed :: (Int, Int) -> [[Int]] -> String
showProcessed  mk lst = trim (showProcessed' mk lst) ++ "\nTime: " ++ (show $ 6*(length $ tail lst)) ++ "\n"
showProcessed' _ []   = []
showProcessed' (m, k) all@(x:xs) = showStack (take m x) ++ showQueue (drop m x) ++ "\n" ++ showProcessed' (m, k) xs
               where showStack []     = []
                     showStack (x:xs) = showFormatted x ++ " -> " ++ showFormatted (positive (x-k)) ++ " -- " ++ 
                                        (if x > k then "Unaccomplished. Queue.\n" else "Accomplished.\n") ++ showStack xs
                     positive x       = if x > 0 then x else 0
                     showQueue x      = if x /= [] then "Queue:\n-----\n" ++ show' x ++ "-----\n" else []
                     show' []         = []
                     show' (x:xs)     = "|" ++ showFormatted x ++ "|" ++ ['\n'] ++ show' xs
                     showFormatted x  = let str = show x in str ++ replicate (3 - length str) ' '

-- Two ways
double = (putStr "Enter m and k: " >> getLine) >>= return . toPair >>=
         (\x -> getLine >>= return . showProcessed x  . process x . readI >>= putStr)

full   = (putStr "Enter m and k: " >> getLine) >>= return . toPair >>=
         (\x -> getLine >>=  return . map (showProcessed x  . process x) . split . readI >>=
         mapM_ (\x -> putStr "\n=== Thread ===\n" >> putStr x))

-- Utils 
readI    = map read . words
toPair x = (head $ readI x, last $ readI x)
split  x = let num = div (length x) 2 in [take num x] ++ [drop num x]
trim   x = (f $ f x) ++ ['\n'] where f = reverse . dropWhile (=='\n')

-- Main
main = flush >> (putStr "Type(Full or Double): " >> getLine) >>= run >> getChar
       where flush = hSetBuffering stdout NoBuffering
             run x = let fst = toLower $ head x in case fst of
                     'd'       -> double
                     'f'       -> full
                     otherwise -> (putStr "No such type. Try again: " >> getLine) >>= run