scroll-1.20250228: Types.hs

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

module Types where

import Control.Monad.ST
import Control.Monad.State.Strict
import Data.Vector.Mutable (MVector)
import Data.Vector (Vector)
import Data.Default
import Data.Tuple
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Map as M
import Data.CaseInsensitive (CI)
import System.Random (StdGen)

import Term

-- Most code that updates the world runs in this monad stack.
type M = StateT S (ST RealWorld)

-- User input.
type Input = Char

-- Game state.
data S = S
	{ world :: World
	, flipSide :: World
	, player :: Player
	, bottomBuffer :: (World, World)
	, topBuffer :: Int
	, peruser :: Peruser
	, randSource :: Rand
	, helpShown :: Bool
	, messages :: [String]
	, spells :: Set Spell
	, poisons :: M.Map (CI Char) PoisonEffect
	, windows :: [Window]
	}

data Window = Window Pos [String]

data Rand = Rand StdGen | DefRand StdGen | NoRand

data Side = CurrentSide | FlipSide | InSide
	deriving (Eq)

type Vec2 a = MVector RealWorld (MVector RealWorld a)
type World = Vec2 Char

-- View of the game to display.
data View = View
	{ viewVisible :: Vector (Vector Char)
	, viewPlayer :: Player
	, viewWindows :: [Window]
	, viewForceRedraw :: Bool
	}

type Pos = (Int, Int) -- x, y (from upper left corner)

type Offset = (Int -> Int, Int -> Int)

data Peruser = Peruser
	{ peruseSpeed :: Int -- ^ lower is faster
	, peruseCountDown :: Int -- ^ next scroll at 0
	}

instance Default Peruser where
	def = Peruser 5 10 -- 10 gives extra time before first at start of game

data Player = Player
	{ playerHead :: Pos
	, playerSwallowing :: Maybe Char
	, playerBody :: [Segment] -- ^ first segment is next to head
	, playerLen :: Int -- ^ including head
	, spellCaster :: Bool
	, playerSpells :: Set Spell
	, playerEnergized :: Bool
	, playerBerzerk :: Bool
	, playerStaggering :: Bool
	}

instance Default Player where
	def = Player
		{ playerHead = (6,6)
		, playerSwallowing = Nothing
		, playerBody = []
		, playerLen = 5
		, spellCaster = False
		, playerSpells = S.empty
		, playerEnergized = False
		, playerBerzerk = False
		, playerStaggering = False
		}

data Segment = Segment
	{ segmentPos :: Pos
	, segmentDirection :: Direction
	, segmentSide :: Side
	, segmentSwallowed :: Maybe Char
	, segmentInvoked :: Bool
	}

data Direction = DLeft | DRight | DUp | DDown | DDive
	deriving (Eq, Ord, Show, Bounded, Enum)

bodyChar :: Direction -> Char
bodyChar DLeft = '<'
bodyChar DRight = '>'
bodyChar DUp = '^'
bodyChar DDown = 'v'
-- not visible, but this prevents accidentially genociding it
bodyChar DDive = '|'

directionOffset :: Direction -> Offset
directionOffset DLeft = (pred, id)
directionOffset DRight = (succ, id)
directionOffset DUp = (id, pred)
directionOffset DDown = (id, succ)
directionOffset DDive = (id, id)

type PoisonEffect = Char -> M NextStep -> M NextStep

data Spell = Spell
	{ spellName :: SpellName
	, spellHint :: String
	, spellIngredients :: Set (CI Char)
	, spellWord :: String -- same as ingredients, but ordered
	, spellAction :: (M NextStep -> M NextStep)
	}

type SpellName = String

instance Eq Spell where
	a == b = (spellName a, spellIngredients a) == (spellName b, spellIngredients b)

instance Ord Spell where
	compare a b = (spellName a, spellIngredients a) `compare` (spellName b, spellIngredients b)

-- Calculates a new state of the world based on the provided Input.
-- Returns new View, and a continuation to handle the next step.
type Step = InputEvent -> M NextStep
data NextStep = NextStep View (Maybe Step)

type Level = [String]

-- Flips to the other side of the scroll.
class Flippable a where
	flipOver :: a -> a

instance Flippable Side where
	flipOver CurrentSide = FlipSide
	flipOver FlipSide = CurrentSide
	flipOver InSide = InSide

instance Flippable S where
	flipOver s = s
		{ world = flipSide s
		, flipSide = world s
		, player = flipOver (player s)
		, bottomBuffer = swap (bottomBuffer s)
		}

instance Flippable Player where
	flipOver p = p { playerBody = map flipOver (playerBody p) }

instance Flippable Segment where
	flipOver s = s { segmentSide = flipOver (segmentSide s) }

class Positioned a where
	getPos :: a -> Pos
	offsetPos :: Offset -> a -> a

instance Positioned Pos where
	getPos = id
	offsetPos (fx, fy) (x, y) = (fx x, fy y)

instance Positioned Player where
	getPos = playerHead
	offsetPos f p = p
		{ playerHead = offsetPos f (playerHead p)
		, playerBody = map (offsetPos f) (playerBody p)
		}

instance Positioned Segment where
	getPos = segmentPos
	offsetPos f s = s { segmentPos = offsetPos f (segmentPos s) }

data Difficulty
	= Easy
	| Medium
	| Hard