curses set game

root / Curses.hsc

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
{-# LANGUAGE ForeignFunctionInterface #-}
module Curses (
    drawChar,
    drawString,
    drawVLine,
    wChgAttr
    ) where

#include <curses.h>

import Prelude hiding (pi)
import UI.HSCurses.Curses
import qualified Data.Char as Char
import Foreign.C.Types
import Foreign.Ptr
import Data.Word

foreign import ccall unsafe hs_curses_acs_ulcorner :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_llcorner :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_urcorner :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_lrcorner :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_rtee     :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_ltee     :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_btee     :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_ttee     :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_hline    :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_vline    :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_plus     :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_s1       :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_s9       :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_diamond  :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_ckboard  :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_degree   :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_plminus  :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_bullet   :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_larrow   :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_rarrow   :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_darrow   :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_uarrow   :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_board    :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_lantern  :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_block    :: IO (#type chtype)
#  ifdef ACS_S3
foreign import ccall unsafe hs_curses_acs_s3       :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_s7       :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_lequal   :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_gequal   :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_pi       :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_nequal   :: IO (#type chtype)
foreign import ccall unsafe hs_curses_acs_sterling :: IO (#type chtype)
#  endif

charWord :: Char -> Word32
charWord = fromIntegral . Char.ord

fixChar :: Char -> IO Word32
fixChar ch
    | ch < '\x7f' = return $ charWord ch
    | ch == ulCorner = hs_curses_acs_ulcorner
    | ch == llCorner = hs_curses_acs_llcorner
    | ch == urCorner = hs_curses_acs_urcorner
    | ch == lrCorner = hs_curses_acs_lrcorner
    | ch == rTee     = hs_curses_acs_rtee
    | ch == lTee     = hs_curses_acs_ltee
    | ch == bTee     = hs_curses_acs_btee
    | ch == tTee     = hs_curses_acs_ttee
    | ch == hLine    = hs_curses_acs_hline
    | ch == vLine    = hs_curses_acs_vline
    | ch == plus     = hs_curses_acs_plus
    | ch == s1       = hs_curses_acs_s1
    | ch == s9       = hs_curses_acs_s9
    | ch == diamond  = hs_curses_acs_diamond
    | ch == ckBoard  = hs_curses_acs_ckboard
    | ch == degree   = hs_curses_acs_degree
    | ch == plMinus  = hs_curses_acs_plminus
    | ch == bullet   = hs_curses_acs_bullet
    | ch == lArrow   = hs_curses_acs_larrow
    | ch == rArrow   = hs_curses_acs_rarrow
    | ch == dArrow   = hs_curses_acs_darrow
    | ch == uArrow   = hs_curses_acs_uarrow
    | ch == board    = hs_curses_acs_board
    | ch == lantern  = hs_curses_acs_lantern
    | ch == block    = hs_curses_acs_block
#  ifdef ACS_S3
    | ch == s3       = hs_curses_acs_s3
    | ch == s7       = hs_curses_acs_s7
    | ch == lEqual   = hs_curses_acs_lequal
    | ch == gEqual   = hs_curses_acs_gequal
    | ch == pi       = hs_curses_acs_pi
    | ch == nEqual   = hs_curses_acs_nequal
    | ch == sterling = hs_curses_acs_sterling
#  endif
    | otherwise = return $ charWord ch

drawChar :: Window -> Char -> IO ()
drawChar w c = throwIfErr_ "waddch" $ fixChar c >>= waddch w

drawString :: Window -> Int -> Int -> String -> IO ()
drawString w y x s = wMove w y x >> mapM_ (drawChar w) s

foreign import ccall unsafe wvline :: Window -> (#type chtype) -> CInt -> IO CInt

drawVLine :: Window -> Int -> Int -> Char -> Int -> IO ()
drawVLine w y x c n = wMove w y x >> fixChar c >>= \c -> throwIfErr_ "wvline" $ wvline w c (fromIntegral n)

foreign import ccall unsafe wchgat :: Window -> CInt -> (#type attr_t) -> CShort -> Ptr a -> IO CInt

wChgAttr :: Window -> Int -> (Attr, Pair) -> IO ()
wChgAttr w n (a, Pair p) = throwIfErr_ "wchgat" $ wchgat w (fromIntegral n) (read (show a)) (fromIntegral p) nullPtr