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