home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / hugs101.zip / hugs101sc.zip / hugsdist / demos / ansi.hs next >
Text File  |  1995-02-14  |  4KB  |  119 lines
  1. -- This is a simple program using ANSI escape sequences to create a program
  2. -- which uses direct cursor addressing and input/output.
  3. --
  4. -- People are often quite surprised the first time they see a program like
  5. -- this written in a functional language.
  6.  
  7.  
  8. -- Basic screen control codes:
  9.  
  10. -- Choose whichever of the following lines is suitable for your system:
  11. cls         = "\ESC[2J"     -- for PC with ANSI.SYS
  12. cls         = "\^L"         -- for Sun window
  13.  
  14. goto x y    = '\ESC':'[':(show y ++(';':show x ++ "H"))
  15. at (x,y) s  = goto x y ++ s
  16. home        = goto 1 1
  17. highlight s = "\ESC[7m"++s++"\ESC[0m"
  18.  
  19.  
  20. -- Some general purpose functions for interactive programs:
  21.  
  22. type Interact             = String -> String
  23.  
  24. end                      :: Interact
  25. end cs                    = ""
  26.  
  27. readChar, peekChar       :: Interact -> (Char -> Interact) -> Interact
  28. readChar eof use []       = eof []
  29. readChar eof use (c:cs)   = use c cs
  30.  
  31. peekChar eof use []       = eof []     -- like readChar, but character is
  32. peekChar eof use cs@(c:_) = use c cs   -- not removed from input stream
  33.  
  34. pressAnyKey              :: Interact -> Interact
  35. pressAnyKey prog          = readChar prog (\c -> prog)
  36.  
  37. unreadChar               :: Char -> Interact -> Interact
  38. unreadChar c prog cs      = prog (c:cs)
  39.  
  40. writeChar                :: Char -> Interact -> Interact
  41. writeChar c prog cs       = c : prog cs
  42.  
  43. writeString              :: String -> Interact -> Interact
  44. writeString s prog cs     = s ++ prog cs
  45.  
  46. writes                   :: [String] -> Interact -> Interact
  47. writes  ss                = writeString (concat ss)
  48.  
  49. ringBell                 :: Interact -> Interact
  50. ringBell                  = writeChar '\BEL'
  51.  
  52.  
  53. -- Screen oriented input/output functions:
  54.  
  55. type Pos           = (Int,Int)
  56.  
  57. clearScreen        = writeString cls
  58. writeAt (x,y) s    = writeString (goto x y ++ s)
  59. moveTo  (x,y)      = writeString (goto x y)
  60.  
  61.  
  62. readAt            :: Pos                  ->  -- Start coordinates
  63.                      Int                  ->  -- Maximum input length
  64.                      (String -> Interact) ->  -- How to use entered string
  65.                      Interact
  66.  
  67. readAt (x,y) l use = writeAt (x,y) (copy l '_') (moveTo  (x,y) (loop 0 ""))
  68.  where loop n s    = readChar (return s) (\c ->
  69.                      case c of '\BS'         -> delete n s
  70.                                '\DEL'        -> delete n s
  71.                                '\n'          -> return s
  72.                                c | n < l     -> writeChar c (loop (n+1) (c:s))
  73.                                  | otherwise -> ringBell (loop n s))
  74.        delete n s  = if n>0 then writeString "\BS_\BS" (loop (n-1) (tail s))
  75.                             else ringBell (loop 0 "")
  76.        return s    = use (reverse s)
  77.  
  78.  
  79. defReadAt         :: Pos                  ->  -- Start coordinates
  80.                      Int                  ->  -- Maximum input length
  81.                      String               ->  -- Default string value
  82.                      (String -> Interact) ->  -- How to use entered string
  83.                      Interact
  84. defReadAt (x,y) l def use
  85.                    = writeAt (x,y) (take l (def++repeat '_')) (
  86.                      readChar (use def) (\c ->
  87.                      if c=='\n' then use def
  88.                                 else unreadChar c (readAt (x,y) l use)))
  89.  
  90. promptReadAt (x,y) l prompt use
  91.                    = writeAt (x,y) prompt (readAt (x+length prompt,y) l use)
  92.  
  93. defPromptReadAt (x,y) l prompt def use
  94.                    = writeAt (x,y) prompt (
  95.                      defReadAt (x+length prompt,y) l def use)
  96.                                   
  97.  
  98. -- A sample program:
  99. -- Enter the expression `run program' in Hugs to try this program out
  100.  
  101. program = writes [ cls,
  102.                    at (17,5)  (highlight "Demonstration program"),
  103.                    at (48,5)  "Version 1.0",
  104.                    at (17,7)  "This program illustrates a simple approach",
  105.                    at (17,8)  "to screen-based interactive programs using",
  106.                    at (17,9)  "the Hugs functional programming system.",
  107.                    at (17,11) "Please press any key to continue ..."
  108.                  ]
  109.           (pressAnyKey
  110.           (promptReadAt (17,15) 18 "Please enter your name: " (\name ->
  111.           (let reply = "Hello " ++ name ++ "!" in
  112.            writeAt (40-(length reply`div` 2),18) reply
  113.           (moveTo (1,23)
  114.           (writeString "I'm waiting...\n"
  115.           (pressAnyKey
  116.           end)))))))
  117.  
  118. -- End of file
  119.