curses set game

root / Interface.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
module Interface (
    Dim, dimOp, dimInc,
    runInterface,
    input, clear,
    clearArea, space,
    attrRst,
    drawStrings,
    drawBox,
    statusMsg, titleMsg,
    Align(..), align,
    dialogue,
    columnize
    ) where

import qualified Data.Char as Char
import qualified Control.Monad as Monad
import qualified Control.Exception
import qualified Data.List as List
import Curses
import UI.HSCurses.Curses
import qualified UI.HSCurses.CursesHelper as CursesH

import Util

type Dim = (Int, Int)
dimOp :: (Int -> Int -> Int) -> Dim -> Dim -> Dim
dimOp op (x1,y1) (x2,y2) = (x1`op`x2,y1`op`y2)
dimInc = dimOp (+) (1,1)

initInterface :: IO ()
initInterface = do
  CursesH.start
  -- startColor
  cBreak True
  echo False
  noDelay stdScr False
  cursSet CursorInvisible
  nop

finiInterface :: IO ()
finiInterface =
  CursesH.end

runInterface :: IO () -> IO ()
runInterface r =
  Control.Exception.finally (initInterface >> r) finiInterface

input :: IO Key
input = refresh >> CursesH.getKey nop

clear :: IO ()
clear = erase >> refresh

drawStrings :: Window -> Dim -> [String] -> IO ()
drawStrings w (y,x) = Monad.zipWithM_ (\y -> drawString w y x) [y..]

drawBox :: Window -> Dim -> Dim -> IO ()
drawBox win (y,x) (h,w) = do
  drawString win y x (ulCorner : replicate (w-2) hLine ++ [urCorner])
  drawVLine win (y+1) x vLine (h-2)
  drawVLine win (y+1) (x+w-1) vLine (h-2)
  drawString win (y+h-1) x (llCorner : replicate (w-2) hLine ++ [lrCorner])

space = ' '
spaces n = replicate n space

clearArea :: Dim -> Dim -> IO ()
clearArea p (h,w) = drawStrings stdScr p $ replicate h $ spaces w

data Align = AtLeft | AtRight | AtCenter
align :: Align -> Int -> String -> String
align a n s 
  | n < l = s
  | otherwise = case a of
    AtLeft -> s ++ p
    AtRight -> p ++ s
    AtCenter -> spaces d2 ++ s ++ spaces (d - d2)
    where
      l = length s
      d = n - l
      d2 = d `div` 2
      p = spaces d

columnize :: [Align] -> [[String]] -> [String]
columnize al sl = map concat sl' where
  cl = List.transpose sl
  ll = map (succ . maximum . map length) cl
  sl' = map (zipWith3 align al ll) sl

attrRst = wAttrSet stdScr (attr0, Pair 0)

statusMsg :: String -> IO ()
statusMsg s = do
  (h, w) <- scrSize
  attrRst
  mvWAddStr stdScr (h-1) 0 (align AtLeft (w-1) s)

titleMsg :: String -> IO ()
titleMsg s = do
  attrRst
  mvWAddStr stdScr 0 0 (align AtCenter 80 s)

dialogue :: String -> [String] -> IO Key
dialogue title msg = do
  ss <- scrSize
  let 
    end = [rTee]++"press a key"++[lTee]
    w = maximum $ map length $ end:title:msg
    h = length msg
    sz = (2+h,2+w)
    pos = dimOp div (dimOp (-) ss sz) (2,2)
  win <- uncurry (newWin (3+h) (2+w)) pos
  -- wClear win
  drawBox win (0,0) sz
  drawString win 0 (1 + (w - length title) `div` 2) title
  drawStrings win (1,1) msg
  drawString win (1+h) (1+w - length end) end
  wRefresh win
  key <- CursesH.getKey nop
  delWin win
  touchWin stdScr
  return key