1module Curses where
2
3import UI.NCurses hiding (Window)
4import Control.Monad.State.Strict
5import qualified Data.Vector as V
6import Data.Vector ((!))
7import Control.Applicative
8import Prelude
9
10import Types
11import View
12
13inCurses :: (Palette -> Curses a) -> IO a
14inCurses a = runCurses $ do
15	void $ setCursorMode CursorInvisible
16	setEcho False
17	palette <- assignColors
18	a palette
19
20data Palette = Palette
21	{ swallowedColor :: ColorID
22	, invokedColor :: ColorID
23	}
24
25assignColors :: Curses Palette
26assignColors = Palette
27	<$> newColorID ColorYellow ColorBlack 1
28	<*> newColorID ColorGreen ColorBlack 2
29
30paint :: Palette -> (Palette -> ColorID) -> Update a -> Update a
31paint palette selectcolor a = do
32	setColor (selectcolor palette)
33	r <- a
34	setColor defaultColorID
35	return r
36
37-- Checks window bounds.
38putGlyph :: ViewOffset -> MaxPos -> Pos -> Glyph -> Update ()
39putGlyph (xoff, yoff) (xmax, ymax) (x,y) g
40	| x' < xmax && x' > 0 && y' < ymax && y' > 0 = do
41		moveCursor (fromIntegral y') (fromIntegral x')
42		drawLineH (Just g) 1
43	| otherwise = return ()
44  where
45	x' = x + xoff
46	y' = y + yoff
47
48headGlyph :: Glyph
49headGlyph = bodyGlyph '@'
50
51bodyGlyph :: Char -> Glyph
52bodyGlyph c = Glyph c [AttributeStandout]
53
54swallowedGlyph :: Char -> Glyph
55swallowedGlyph c = Glyph c [AttributeStandout]
56
57stomachColor :: Segment -> (Palette -> ColorID)
58stomachColor s
59	| segmentInvoked s = invokedColor
60	| otherwise = swallowedColor
61
62drawPlayer :: ViewOffset -> MaxPos -> Palette -> Player -> Update ()
63drawPlayer offset maxpos palette p = do
64	-- draw the body from the last segment to first, since
65	-- segments sometimes sit on top of other segments.
66	forM_ (reverse (playerBody p)) $
67		drawSegment offset maxpos palette
68
69	-- draw head last so the cursor is over it
70	putGlyph offset maxpos (playerHead p) headGlyph
71
72drawSegment :: ViewOffset -> MaxPos -> Palette -> Segment -> Update ()
73drawSegment offset maxpos palette s
74	| segmentSide s == CurrentSide =
75		case segmentSwallowed s of
76			Nothing -> putGlyph offset maxpos (segmentPos s) $ bodyGlyph $
77				bodyChar $ segmentDirection s
78			Just c -> paint palette (stomachColor s) $
79				putGlyph offset maxpos (segmentPos s) $ swallowedGlyph c
80	| otherwise = return ()
81
82drawWindow :: Integer -> Int -> Window -> Update ()
83drawWindow ymax xmax (Window (x,y) l) =
84	when (x < xmax) $ do
85		let xI = fromIntegral x
86		let yI = fromIntegral y
87		forM_ [0..length l - 1] $ \n -> do
88			let yp = yI+fromIntegral n
89			when (yp < ymax) $ do
90				moveCursor yp xI
91				drawString $ trim (l !! n)
92  where
93	trim = take (xmax - x - 1)
94
95displayView :: View -> Palette -> Maybe Integer -> ViewOffset -> Curses (Maybe Event, ViewOffset)
96displayView view palette timeoutms oldoffset = loop
97  where
98	yv = viewVisible view
99	loop = do
100		w <- defaultWindow
101		(ymaxI, xmaxI) <- screenSize
102		let ymax = fromIntegral ymaxI
103		let xmax = fromIntegral xmaxI
104
105		let maxpos = (xmax, ymax)
106		let newoffset@(xdelta, ydelta) = adjustOffset view oldoffset maxpos
107
108		let (ytrimmer, yoff) = viewPort ydelta ymax (V.length yv)
109		let yvtrimmed = ytrimmer yv
110
111		let xsample = V.head yv
112		let (xtrimmer, xoff) = viewPort xdelta xmax (V.length xsample)
113		let xoffI = fromIntegral xoff
114
115		updateWindow w $ do
116			let clearline = drawLineH (Just (Glyph ' ' [])) xmaxI
117			forM_ [0..ymax-2] $ \y -> do
118				let yI = fromIntegral y
119				let y' = y - yoff
120				moveCursor yI 0
121				void clearline
122				when (y' < V.length yvtrimmed && y' >= 0) $ do
123					let cs = V.toList $ xtrimmer $
124						yvtrimmed ! y'
125					unless (null cs) $ do
126						moveCursor yI xoffI
127						drawString cs
128
129			drawPlayer newoffset maxpos palette (viewPlayer view)
130			mapM_ (drawWindow ymaxI xmax) (viewWindows view)
131		render
132
133		mev <- getEvent w timeoutms
134		case mev of
135			Just (EventMouse _ _) -> loop
136			Just (EventUnknown _) -> loop
137			Just EventResized -> loop
138			Just ev -> return (Just ev, newoffset)
139			Nothing -> return (Nothing, newoffset)
140
141arrowDirection :: Event -> Maybe Direction
142arrowDirection (EventSpecialKey KeyLeftArrow) = Just DLeft
143arrowDirection (EventSpecialKey KeyDownArrow) = Just DDown
144arrowDirection (EventSpecialKey KeyUpArrow) = Just DUp
145arrowDirection (EventSpecialKey KeyRightArrow) = Just DRight
146arrowDirection (EventSpecialKey KeyEnter) = Just DDive
147arrowDirection _ = Nothing
148