Ticket #5996: Main.hs

File Main.hs, 1.7 KB (added by igloo, 6 years ago)
Line 
1
2module Main (main) where
3
4import System.Environment
5
6goto :: Int -> Int -> String
7goto x y = show y ++ show x
8
9type Interact             = String -> String
10
11end                      :: Interact
12end _                     = ""
13
14readChar                 :: Interact -> (Char -> Interact) -> Interact
15readChar eof _   []       = eof []
16readChar _   use (c:cs)   = use c cs
17
18writeChar                :: Char -> Interact -> Interact
19writeChar c prog cs       = c : prog cs
20
21writeString              :: String -> Interact -> Interact
22writeString s prog cs     = s ++ prog cs
23
24ringBell                 :: Interact -> Interact
25ringBell                  = writeChar '\BEL'
26
27type Pos           = (Int,Int)
28
29writeAt :: Pos -> String -> Interact -> Interact
30writeAt (x,y) s    = writeString (goto x y ++ s)
31
32readAt :: (String -> Interact) -> Interact
33readAt use = writeAt (17,15) (copy 18 '_') (loop 0 "")
34 where loop :: Int -> String -> Interact
35       loop n s    = readChar (ret s) (\c ->
36                     case c of '\BS'         -> delete n s
37                               '\DEL'        -> delete n s
38                               '\n'          -> ret s
39                               _ | n < 18    -> writeChar c (loop (n+1) (c:s))
40                                 | otherwise -> ringBell (loop n s))
41       delete n s  = if n>0 then writeString "\BS_\BS" (loop (n-1) (tail s))
42                            else ringBell (loop 0 "")
43       ret s       = use (reverse s)
44
45program :: Interact
46program = readAt (\name ->
47          (let reply = "Hello " ++ name ++ "!" in
48           writeAt (40,18) reply
49          end))
50
51main :: IO ()
52main = do
53  (n:_) <- getArgs
54  interact (foldr (.) id (take (read n) (repeat program)))
55
56copy    :: Int -> a -> [a]
57copy n x = take n (repeat x)
58