scroll-1.20250228: Term/Curses.hs

module Term.Curses (
	Palette,
	inCurses,
	displayView,
	arrowDirection,
) where

import UI.NCurses hiding (Window)
import Control.Monad (void, unless, when)
import Data.Foldable (forM_)
import qualified Data.Vector as V
import Data.Vector ((!))
import Control.Applicative
import Prelude

import Types
import Term
import View

inCurses :: (Palette -> Curses a) -> IO a
inCurses a = runCurses $ do
	void $ setCursorMode CursorInvisible
	setEcho False
	palette <- assignColors
	a palette

data Palette = Palette
	{ swallowedColor :: ColorID
	, invokedColor :: ColorID
	}

assignColors :: Curses Palette
assignColors = Palette
	<$> newColorID ColorYellow ColorBlack 1
	<*> newColorID ColorGreen ColorBlack 2

paint :: Palette -> (Palette -> ColorID) -> Update a -> Update a
paint palette selectcolor a = do
	setColor (selectcolor palette)
	r <- a
	setColor defaultColorID
	return r

-- Checks window bounds.
putGlyph :: ViewOffset -> MaxPos -> Pos -> Glyph -> Update ()
putGlyph (xoff, yoff) (xmax, ymax) (x,y) g
	| x' < xmax && x' > 0 && y' < ymax && y' > 0 = do
		moveCursor (fromIntegral y') (fromIntegral x')
		drawLineH (Just g) 1
	| otherwise = return ()
  where
	x' = x + xoff
	y' = y + yoff

headGlyph :: Glyph
headGlyph = bodyGlyph '@'

bodyGlyph :: Char -> Glyph
bodyGlyph c = Glyph c [AttributeStandout]

swallowedGlyph :: Char -> Glyph
swallowedGlyph c = Glyph c [AttributeStandout]

stomachColor :: Segment -> (Palette -> ColorID)
stomachColor s
	| segmentInvoked s = invokedColor
	| otherwise = swallowedColor

drawPlayer :: ViewOffset -> MaxPos -> Palette -> Player -> Update ()
drawPlayer offset maxpos palette p = do
	-- draw the body from the last segment to first, since
	-- segments sometimes sit on top of other segments.
	forM_ (reverse (playerBody p)) $
		drawSegment offset maxpos palette

	-- draw head last so the cursor is over it
	putGlyph offset maxpos (playerHead p) headGlyph

drawSegment :: ViewOffset -> MaxPos -> Palette -> Segment -> Update ()
drawSegment offset maxpos palette s
	| segmentSide s == CurrentSide =
		case segmentSwallowed s of
			Nothing -> putGlyph offset maxpos (segmentPos s) $ bodyGlyph $
				bodyChar $ segmentDirection s
			Just c -> paint palette (stomachColor s) $
				putGlyph offset maxpos (segmentPos s) $ swallowedGlyph c
	| otherwise = return ()

drawWindow :: Integer -> Int -> Window -> Update ()
drawWindow ymax xmax (Window (x,y) l) =
	when (x < xmax) $ do
		let xI = fromIntegral x
		let yI = fromIntegral y
		forM_ [0..length l - 1] $ \n -> do
			let yp = yI+fromIntegral n
			when (yp < ymax) $ do
				moveCursor yp xI
				drawString $ trim (l !! n)
  where
	trim = take (xmax - x - 1)

displayView :: View -> Palette -> Maybe Integer -> ViewOffset -> Curses (Maybe InputEvent, ViewOffset)
displayView view palette timeoutms oldoffset = loop 
  where
	yv = viewVisible view
	loop = do
		w <- defaultWindow
		(ymaxI, xmaxI) <- screenSize
		let ymax = fromIntegral ymaxI
		let xmax = fromIntegral xmaxI

		let maxpos = (xmax, ymax)
		let newoffset@(xdelta, ydelta) = adjustOffset view oldoffset maxpos

		let (ytrimmer, yoff) = viewPort ydelta ymax (V.length yv)
		let yvtrimmed = ytrimmer yv

		let xsample = V.head yv
		let (xtrimmer, xoff) = viewPort xdelta xmax (V.length xsample)
		let xoffI = fromIntegral xoff

		updateWindow w $ do
			let clearline = drawLineH (Just (Glyph ' ' [])) xmaxI
			forM_ [0..ymax-2] $ \y -> do
				let yI = fromIntegral y
				let y' = y - yoff
				moveCursor yI 0
				void clearline
				when (y' < V.length yvtrimmed && y' >= 0) $ do
					let cs = V.toList $ xtrimmer $
						yvtrimmed ! y'
					unless (null cs) $ do
						moveCursor yI xoffI
						drawString cs

			drawPlayer newoffset maxpos palette (viewPlayer view)
			mapM_ (drawWindow ymaxI xmax) (viewWindows view)
		render

		mev <- getEvent w timeoutms
		case mev of
			Just (EventMouse _ _) -> loop
			Just (EventUnknown _) -> loop
			Just EventResized -> loop
			Just ev -> return (Just (InputEvent ev), newoffset)
			Nothing -> return (Nothing, newoffset)

arrowDirection :: InputEvent -> Maybe Direction
arrowDirection (InputEvent (EventSpecialKey KeyLeftArrow)) = Just DLeft
arrowDirection (InputEvent (EventSpecialKey KeyDownArrow)) = Just DDown
arrowDirection (InputEvent (EventSpecialKey KeyUpArrow)) = Just DUp
arrowDirection (InputEvent (EventSpecialKey KeyRightArrow)) = Just DRight
arrowDirection (InputEvent (EventSpecialKey KeyEnter)) = Just DDive
arrowDirection _ = Nothing