diff --git a/app/Main.hs b/app/Main.hs index 26d39c4de..68fc8f429 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -6,9 +6,6 @@ import Shaders import Render import Shapes -import Dodge.Rendering -import Dodge.RenderPicture -import Dodge.Picture import Dodge.Prototypes import Dodge.Data import Dodge.Initialisation @@ -17,7 +14,11 @@ import Dodge.Layout import Dodge.LoadSound import Dodge.Update import Dodge.KeyEvents -import Dodge.Preload +import Dodge.Rendering + +import Picture +import Picture.Render +import Picture.Preload import Control.Concurrent import Control.Lens @@ -38,31 +39,6 @@ initWorld = initialWorld pps = [(0,0),(50,0),(0,25)] ppt = [(0,0),(-50,0),(20,25)] -tSh = TextShape - [((0.0,0.0,0),(1,0,1,1),(s,1)) - ,((0.5,0.0,0),(1,1,1,1),(e,1)) - ,((0.5,1.0,0),(1,1,1,1),(e,0)) - ,((0.0,1.0,0),(1,1,1,1),(s,0)) - ] - where x = 1/128 - s = 20 * x - e = s + x -tSh' = TShape' - [0.0,0.0,0,1,0,1,1,s,1 - ,0.5,0.0,0,1,1,1,1,e,1 - ,0.5,1.0,0,1,1,1,1,e,0 - ,0.0,1.0,0,1,1,1,1,s,0 - ] TriangleFan - where x = 1/128 - s = 20 * x - e = s + x -tSha = TShape' - [0.0,0.0,0,1,1,1,1 - ,50 ,0.0,0,1,1,1,1 - ,50 ,50 ,0,1,1,1,1 - ,0.0,1.0,0,1,1,1,1 - ] TriangleFan - main :: IO () main = do -- loadedSounds <- loadSounds @@ -70,15 +46,17 @@ main = do "windowName" 800 600 doPreload' + cleanUpPreload (initializeWorld $ generateFromTree lev1 $ initWorld) (-- \((bs:fs:ts:_),tes) w -> --do render setparams w egFade \preData w -> --do render setparams w egFade - --renderPicture preData (draw blank w) - renderPicture' preData (pictures' [--scale' 0.5 0.9 $ polygon' [(0,0),(0,0.5),(0.5,0.5),(0.5,0.0)] - scale' 0.0005 0.0005 $ text' "asdf" - ] - ) - -- renderTex'' preData tSh + renderPicture' preData (draw blank w) +-- renderPicture' preData +-- (pictures [scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)] +-- ,scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)] +-- ,color red $ scale 0.0005 0.0005 $ text "asdf" +-- ] +-- ) ) handleEvent (\w -> Just $ update w) diff --git a/package.yaml b/package.yaml index 41c8e2e91..ba1ad85e9 100644 --- a/package.yaml +++ b/package.yaml @@ -38,6 +38,8 @@ dependencies: - monad-loops - JuicyPixels - vector +- dlist +- deepseq library: source-dirs: src @@ -48,8 +50,15 @@ executables: source-dirs: app ghc-options: - -threaded + - -O2 - -rtsopts - -with-rtsopts=-N + - -fno-liberate-case + - -fno-state-hack + - -funfolding-use-threshold1000 + - -funfolding-keeness-factor1000 + - -fllvm + - -optlo-O3 dependencies: - loop diff --git a/src/Dodge/AIs.hs b/src/Dodge/AIs.hs new file mode 100644 index 000000000..09f813b14 --- /dev/null +++ b/src/Dodge/AIs.hs @@ -0,0 +1,1966 @@ +module Dodge.AIs where +-- imports {{{ +import Dodge.Data +import Dodge.Base +import Dodge.Path +import Dodge.SoundLogic +import Dodge.CreatureActions +import Dodge.KeyEvents +import Dodge.RandomHelp +import Dodge.WorldActions +import Dodge.CreatureState + +import Geometry +import Picture + +import Data.List +import Data.Char +import Data.Maybe +import Data.Function +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.PatriciaTree +import Data.Graph.Inductive.Query.SP +import Codec.BMP +import qualified Data.ByteString as B +import Control.Lens +import Control.Applicative +import Control.Monad.State +import Control.Monad +--import Control.Monad.Either +--import Control.Functor.Zip +import qualified SDL as SDL + +import System.Random +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import qualified Data.Map as M + +import Foreign.ForeignPtr +import Control.Concurrent +---} + +--killCr :: World -> (World -> World) -> Creature -> ((World -> World,StdGen), Maybe Creature) +--killCr w f cr = ((g . f, _randGen w),Nothing) +-- where crBeforeDeath = colCrWall w $ cr +-- addCorpse = insertNewKey $ uncurry translate (_crPos crBeforeDeath) +-- $ rotate (radToDeg (_crDir cr)) +-- (_crCorpse cr) +-- maybeIt = evalState (maybeTakeOne $ IM.elems (_crInv cr)) (_randGen w) +-- insertIt = case maybeIt of +-- Just it -> createItemAt (offset +.+ _crPos crBeforeDeath) +-- (FlIt {_flIt=it,_flItPos=(0,0),_flItRot=rot,_flItID=0}) +-- Nothing -> id +-- offset = _crRad cr *.* unitVectorAtAngle rot +-- (rot,_) = randomR (-pi,pi) $ _randGen w +-- g = stopSoundFrom (CrWeaponSound (_crID cr)) . over decorations addCorpse . insertIt + + +factionIs :: Faction -> Creature -> Bool +factionIs f c = (_faction $ _crState $ c) == f + +lineOrth :: Point2 -> IM.IntMap Creature -> Point2 -> Point2 +lineOrth ypos crs cpos = p + where ps = map _crPos $ IM.elems crs + cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps + p | dist cen ypos < 20 = ypos + | otherwise = errorClosestPointOnLine 500 ypos (ypos +.+ vNormal (cen -.- ypos)) cpos + +lineUp :: Point2 -> IM.IntMap Creature -> Point2 -> Point2 +lineUp ypos crs cpos = p + where ps = map _crPos $ IM.elems crs + cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps + p = (0.05 *.* ypos) +.+ (0.95 *.* errorClosestPointOnLine 500 cen ypos cpos) + +holdForm :: Point2 -> IM.IntMap Creature -> Point2 -> Point2 +holdForm ypos crs cpos = p + where ps = map _crPos $ IM.elems crs + cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps + p | dist cen ypos < 20 = ypos + | otherwise = ypos +.+ cpos -.- cen + +-- not nice, a kind of encircle +spreadOut :: Point2 -> IM.IntMap Creature -> Point2 -> Point2 +spreadOut ypos crs cpos = p + where ps = map _crPos $ IM.elems crs + cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps + p | dist cen ypos < 30 = ypos + | otherwise = ypos +.+ (spreadFactor *.* cpos -.- cen) + spreadFactor | dist ypos cpos > 200 = 1 + | otherwise = 5 +---- +---- -- generalised swarm ai, works out where you go from the position of your flock +---- swarmAI :: (Point -> IM.IntMap Creature -> Point -> Point) -> Int -> World -> World +---- swarmAI f cid w = +---- let cr = _creatures w IM.! cid +---- cpos = _crPos cr +---- damageYou = over (creatures . ix 0 . crHP) (\hp -> hp - 10) . soundOnce hitSound +---- ypos = _crPos $ you w +---- flockers = IM.filter (flip (canSeePoint cid) w . _crPos) +---- $ IM.filter (factionIs $ _faction $ _crState cr) +---- $ _creatures w +---- tp = f ypos flockers cpos +---- combinedRad = _crRad cr + _crRad (you w) +---- replaceGoal newGoals = over (creatures . ix cid . crState . goals) +---- (\gs -> newGoals ++ tail gs) +---- addGoal newGoals = over (creatures . ix cid . crState . goals) +---- (\gs -> newGoals ++ gs) +---- replaceAction newActions = over (creatures . ix cid . crState . goals) +---- (\((_:as):ass) -> (newActions ++ as):ass) +---- addAction newActions = over (creatures . ix cid . crState . goals) +---- (\(as:ass) -> (newActions++as):ass) +---- in if _crHP cr <= 0 then killCr cid w else +---- case head $ _goals $ _crState cr of +---- [] | canSee cid (_yourID w) w +---- -> replaceGoal [[MoveToFor tp 10]] w +---- | otherwise -> w +---- (MoveToFor p x:_) +---- | dist ypos cpos < combinedRad + 5 +---- && abs ((_crDir cr) - argV (ypos -.- cpos)) < pi/4 -- THIS WON'T WORK +---- -- think about when crdir is 0.1 and yposdir is (2pi - epsilon) +---- +---- && x == 0 +---- -> over (creatures . ix cid . crPos) +---- (+.+ (12 *.* errorNormalizeVAI (ypos -.- cpos))) +---- $ replaceAction [MeleeAttack 5] +---- $ damageYou +---- w +---- | canSee cid (_yourID w) w && dist cpos ypos < 50 +---- -> mvForward 2 cid $ turnTowardSpeed 0.5 ypos cid +---- $ replaceAction [MoveToFor ypos (max 0 (x-1))] w +---- | x == 0 && canSee cid (_yourID w) w +---- -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid +---- $ replaceAction [MoveToFor tp 0] w +---- | x == 0 -> replaceAction [MoveToFor p 10] w +---- | canSee cid (_yourID w) w +---- -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid +---- $ replaceAction [MoveToFor p (x-1)] w +---- | dist cpos p < 20 -> w +---- | otherwise -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid w +---- (MeleeAttack x:_) +---- | x == 0 -> replaceAction [WaitFor 5] w +---- | otherwise -> replaceAction [MeleeAttack (x-1)] w +---- (WaitFor x:gls)| x == 0 -> replaceAction [] w +---- | canSee cid (_yourID w) w +---- -> turnTowardSpeed 0.05 ypos cid +---- $ replaceAction [WaitFor (x-1)] w +---- | otherwise -> replaceAction [WaitFor (x-1)] w +---- +---- encircleAI' :: Int -> World -> World +---- encircleAI' cid w = +---- let cr = _creatures w IM.! cid +---- cpos = _crPos cr +---- damageYou = over (creatures . ix 0 . crHP) (\hp -> hp - 10) . soundOnce hitSound +---- ypos = _crPos $ you w +---- flockers = IM.filter (flip (canSeePoint cid) w . _crPos) +---- $ IM.filter (factionIs $ EncircleFlock) +---- $ _creatures w +---- tp | length flockers <= 1 = ypos +---- | otherwise = ypos +.+ +---- f (max 0 (magV (ypos -.- cenp) - 30) ) +---- *.* safeNormalizeV (cpos -.- cenp) +---- where f x = 150 * sigmoid (x-10) +---- cenp = (1 / fromIntegral (length flockers)) *.* +---- foldr1 (+.+) +---- (map _crPos $ IM.elems flockers) +---- combinedRad = _crRad cr + _crRad (you w) +---- replaceGoal newGoals = over (creatures . ix cid . crState . goals) +---- (\gs -> newGoals ++ tail gs) +---- addGoal newGoals = over (creatures . ix cid . crState . goals) +---- (\gs -> newGoals ++ gs) +---- replaceAction newActions = over (creatures . ix cid . crState . goals) +---- (\((_:as):ass) -> (newActions ++ as):ass) +---- addAction newActions = over (creatures . ix cid . crState . goals) +---- (\(as:ass) -> (newActions++as):ass) +---- in if _crHP cr <= 0 then killCr cid w else +---- case head $ _goals $ _crState cr of +---- [] | canSee cid (_yourID w) w +---- -> replaceGoal [[MoveToFor tp 10]] w +---- | otherwise -> w +---- (MoveToFor p x:_) +---- | dist ypos cpos < combinedRad + 5 +---- && abs ((_crDir cr) - argV (ypos -.- cpos)) < pi/4 -- same error as above +---- && x == 0 +---- -> over (creatures . ix cid . crPos) +---- (+.+ (12 *.* errorNormalizeVAI (ypos -.- cpos))) +---- $ replaceAction [MeleeAttack 5] +---- $ damageYou +---- w +---- | canSee cid (_yourID w) w && dist cpos ypos < 50 +---- -> mvForward 2 cid $ turnTowardSpeed 0.5 ypos cid +---- $ replaceAction [MoveToFor ypos (max 0 (x-1))] w +---- | x == 0 && canSee cid (_yourID w) w +---- -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid +---- $ replaceAction [MoveToFor tp 0] w +---- | x == 0 -> replaceAction [MoveToFor p 10] w +---- | canSee cid (_yourID w) w +---- -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid +---- $ replaceAction [MoveToFor p (x-1)] w +---- | dist cpos p < 20 -> w +---- | otherwise -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid w +---- (MeleeAttack x:_) +---- | x == 0 -> replaceAction [WaitFor 5] w +---- | otherwise -> replaceAction [MeleeAttack (x-1)] w +---- (WaitFor x:gls)| x == 0 -> replaceAction [] w +---- | canSee cid (_yourID w) w +---- -> turnTowardSpeed 0.02 ypos cid +---- $ replaceAction [WaitFor (x-1)] w +---- | otherwise -> replaceAction [WaitFor (x-1)] w + +spawnerAI :: Creature -> World -> (World -> World,StdGen) -> Creature + -> ((World -> World, StdGen), Maybe Creature) +spawnerAI spawn w (f,g) cr = + let dir = _crDir cr + cid = _crID cr + cpos = _crPos cr + ypos = _crPos $ you w + replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs) + addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ gs) + replaceAction newActions + = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) + addAction newActions + = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) + + needChild = length (filter (\cr' -> (cr' ^? crState . faction) == Just (SpawnedBy cid)) + $ IM.elems $ _creatures w) + < 15 + spawnChild = placeCrFaction spawn (SpawnedBy cid) (cpos +.+ rotateV dir (1,0)) cpos (_crDir cr) + in --if _crHP cr <= 0 then killCr w f cr else + case head $ _goals $ _crState cr of + (WaitFor x:_) | x == 0 && needChild + -> ( (spawnChild . f , g) + ,replaceAction [WaitFor 200] $ over crDir (+ 1) cr + ) + | canSee cid (_yourID w) w + -> ( (f , g) + ,replaceAction [WaitFor (max 0 (x-1))] + $ set (crDir) (argV (ypos -.- cpos)) cr ) + | otherwise -> ( (f , g) + ,replaceAction [WaitFor (max 0 (x-1))] cr) + +placeCrFaction :: Creature -> Faction -> Point2 -> Point2 -> Float -> World -> World +placeCrFaction cr fact p op rot w = over creatures addCr w + where addCr crs = IM.insert (newKey crs) + ( set (crState . faction) fact + $ cr {_crPos = p,_crOldPos = op,_crDir = rot,_crID = newKey crs} + ) + crs + + +chaseAI :: + World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature) +chaseAI w (f,g') cr = + let cid = _crID cr + cpos = _crPos cr + damageYou = over (creatures . ix 0 . crState . crDamage) addDam + . soundOnce (fromIntegral hitSound) + addDam dams = (( Blunt 100 cpos cpos cpos ) : dams ) + ypos = _crPos $ you w + combinedRad = _crRad cr + _crRad (you w) + (a,g) = randomR (-0.2,0.2) g' + (wtime,g1) = randomR (15,25) g' + randomTurn = over crDir (+a) + randomTurn2 = over crDir (+(signum a)) + isCrowded = (length $ IM.elems $ IM.filter isCloseFaction (_creatures w)) > 2 + isCloseFaction cr' = _faction (_crState cr') == _faction (_crState cr) + && dist cpos (_crPos cr') < 25 + replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs) + addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ gs) + replaceAction newActions + = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) + addAction newActions + = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) + in --if _crHP cr <= 0 then killCr w f cr else + case head $ _goals $ _crState cr of + [] -> ((f, g') , replaceGoal [] cr) + (Wait:_) | dist cpos ypos < 900 && hasLOS cpos ypos w + -> ((f ,g') + ,addGoal [[WaitFor wtime,MoveTo ypos]] cr) + | dist cpos ypos < 900 && hasLOSIndirect cpos ypos w + -> ((f , g') + ,addGoal [[WaitFor wtime,PathTo ypos]] cr) + | otherwise -> ( (f , g') + ,Just cr) + (WaitFor x:gls)| x == 0 -> ( (f , g') + ,replaceAction [] cr +-- $ drawCircleAtForCol cpos 10 (withAlpha 0.5 cyan) + ) + | hasLOS cpos ypos w + -> ( (f, g') + ,replaceAction [WaitFor (x-1)] $ crTurnTowardSpeed 0.05 ypos cr + ) + | otherwise -> ( (f, g') + , replaceAction [WaitFor (x-1)] cr ) + (MoveTo p:gls) + | dist ypos cpos < combinedRad + 5 + && abs ((_crDir cr) - argV (ypos -.- cpos)) < pi/4 -- same error as above + -> ( (damageYou . f , g') + , replaceAction [MeleeAttack 5] $ + over crPos + (+.+ (12 *.* errorNormalizeVAI (ypos -.- cpos))) cr + ) + | hasLOS cpos ypos w -> ( (f , g) + , replaceAction [MoveTo ypos] + $ crMvForward 2.5 $ randomTurn + $ crTurnTowardSpeed 0.05 p cr + ) + | dist p cpos < 10 -> ( (f, g') + , replaceAction [] cr) + | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 + -> ( (f ,g' ) + , Just $ crTurnTowardSpeed 0.05 p cr) + | otherwise -> ( (f, g' ) + , Just $ crMvForward 2.5 $ crTurnTowardSpeed 0.05 p cr) + (MoveToFor p x:gls) + | hasLOS cpos ypos w -> + ( (f , g ) + , replaceAction [MoveTo ypos] + $ crMvForward 2.5 $ randomTurn $ crTurnTowardSpeed 0.05 p cr + ) + | dist p cpos < 10 -> ( (f , g) + , replaceAction [] cr) + | x == 0 -> ( (f , g) + , replaceAction [] cr) + | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 + -> ( (f , g) + , replaceAction [MoveToFor p (max 0 (x-1))] + $ crTurnTowardSpeed 0.05 p cr) + | otherwise -> ( (f , g) + , replaceAction [MoveToFor p (max 0 (x-1))] + $ crMvForward 2.5 $ crTurnTowardSpeed 0.05 p cr) + (PathTo p:_) + | dist p cpos < 10 -> ( (f , g) + , replaceAction [] cr +-- $ drawCircleAtForCol p 10 (withAlpha 0.5 blue) + ) + | hasLOS cpos p w -> ( (f , g) + , addAction [MoveToFor p 10] cr +-- $ drawCircleAtForCol p 10 (withAlpha 0.5 green) + ) + | otherwise -> + --((f, g) , replaceAction [] cr) +-- case makePathBetweenPs cpos p w of +-- Just (q:_) -> ( (f , g) +-- +-- , addAction [MoveToFor q 10] cr +-- ) +-- _ -> ((f , g) +-- +-- , replaceAction [] cr +-- ) + case pointTowardsGoal cpos p w of + Just q -> ( (f , g) + + , addAction [MoveToFor q 10] cr + ) + _ -> ((f , g) + + , replaceAction [] cr + ) + +-- case pointTowardsGoal' cpos p w of + -- Right q -> addAction [MoveToFor q 10] +----- let ns = map fst $ concatMap doublePair $ _pathGraph' w +----- a' = listToMaybe $ sortBy (compare `on` dist cpos) $ ns +----- b' = listToMaybe $ sortBy (compare `on` dist p) $ ns +----- g :: World -> World +----- g = fromMaybe id $ fmap (\p -> drawCircleAtForCol p 10 yellow) a' +----- h = fromMaybe id $ fmap (\p -> drawCircleAtForCol p 10 blue) b' +----- incf = incidenceToFunction $ pairsToIncidence +----- $ concatMap doublePair $ _pathGraph' w +----- as :: [Point] +----- as = concat $ maybeToList $ fmap incf a' +----- g' w = foldr (\p -> drawCircleAtForCol p 5 orange) w as +----- h' qs w = foldr (\p -> drawCircleAtForCol p 5 orange) w qs +----- in case makePath' <$> return incf <*> b' <*> a' of +----- Just (q:qs) -> ( f . h' qs +----- . drawCircleAtForCol q 10 magenta +----- , addAction [MoveToFor q 10] cr +----- -- $ drawLineForCol ((cpos : (concat $ maybeToList $ makePathBetweenPs +----- -- cpos p w)) ++ [p]) 50 red +----- ) +------- Left s -> error s +------- - -> (f,cr) +----- _ -> ( f +----- . g . h . g' +----- , replaceAction [] cr +----- ) + (MeleeAttack x:_) + | x == 0 -> ( (f , g) + , replaceAction [WaitFor wtime] cr ) + | otherwise -> ( (f , g) + , replaceAction [MeleeAttack (x-1)] cr ) + +---- meleeAI' :: Int -> World -> World +---- meleeAI' cid w = let cr = _creatures w IM.! cid +---- cpos = _crPos cr +---- damageYou = over (creatures . ix 0 . crHP) (\hp -> hp - 10) . soundOnce hitSound +---- ypos = _crPos $ you w +---- combinedRad = _crRad cr + _crRad (you w) +---- (a,g) = randomR (-0.2,0.2) $ _randGen w +---- (wtime,g1) = randomR (15,25) $ _randGen w +---- randomTurn = set randGen g . over (creatures . ix cid . crDir) (+a) +---- randomTurn2 = set randGen g . over (creatures . ix cid . crDir) (+(signum a)) +---- isCrowded = (length $ IM.elems $ IM.filter isCloseFaction (_creatures w)) > 2 +---- isCloseFaction cr' = _faction (_crState cr') == ChaseCritters +---- && dist cpos (_crPos cr') < 25 +---- replaceGoal newGoals = over (creatures . ix cid . crState . goals) +---- (\gs -> newGoals ++ tail gs) +---- addGoal newGoals = over (creatures . ix cid . crState . goals) +---- (\gs -> newGoals ++ gs) +---- replaceAction newActions = over (creatures . ix cid . crState . goals) +---- (\((_:as):ass) -> (newActions ++ as):ass) +---- addAction newActions = over (creatures . ix cid . crState . goals) +---- (\(as:ass) -> (newActions++as):ass) +---- in if _crHP cr <= 0 then killCr cid w else +---- case head $ _goals $ _crState cr of +---- [] | canSee cid (_yourID w) w +---- -> replaceGoal [[MoveToFor ypos 10]] w +---- | canSeeIndirect cid (_yourID w) w +---- -> addGoal [[PathTo ypos]] w +---- | otherwise -> replaceGoal [] w +---- (WaitFor x:gls)| x == 0 -> replaceAction [] w +---- | canSee cid (_yourID w) w +---- -> turnTowardSpeed 0.05 ypos cid +---- $ replaceAction [WaitFor (x-1)] w +---- | otherwise -> replaceAction [WaitFor (x-1)] w +---- (MoveToFor p x:gls) +---- | dist ypos cpos < combinedRad + 5 +---- && abs ((_crDir cr) - argV (ypos -.- cpos)) < pi/4 -- same error as above +---- -- && x == 0 +---- -> over (creatures . ix cid . crPos) +---- (+.+ (12 *.* errorNormalizeVAI (ypos -.- cpos))) +---- $ replaceAction [MeleeAttack 5] +---- $ damageYou +---- w +---- | x == 0 && isCrowded -> replaceAction [] $ randomTurn2 w +---- | canSee cid (_yourID w) w -> replaceGoal [[MoveToFor ypos (max 0 (x-1))]] +---- $ mvForward 2.5 cid $ randomTurn $ turnTowardSpeed 0.05 p cid w +---- | dist p cpos < 10 -> replaceAction [] w +---- | x == 0 -> replaceAction [] w +---- -- | not (canSeePoint cid p w) -> replaceAction [PathTo p] w +---- -- | not (canSeePoint cid p w) -> replaceAction [] w +---- | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 +---- -> replaceAction [MoveToFor p (max 0 (x-1))] $ turnTowardSpeed 0.05 p cid w +---- | otherwise -> replaceAction [MoveToFor p (max 0 (x-1))] +---- $ mvForward 2.5 cid $ turnTowardSpeed 0.05 p cid w +---- (PathTo p:_) +---- | dist p cpos < 10 -> replaceAction [] w +---- | canSeePoint cid p w -> addAction [MoveToFor p 10] w +---- | otherwise -> +---- case pointTowardsGoal' cpos p w of +---- Right q -> addAction [MoveToFor q 10] +---- -- $ drawCircleAtForCol q 10 magenta +---- -- $ drawLineForCol ((cpos : (concat $ maybeToList $ makePathBetweenPs +---- -- cpos p w)) ++ [p]) 50 red +---- w +---- --Left s -> error s +---- _ -> replaceAction [] w +---- (MeleeAttack x:_) +---- | x == 0 -> replaceAction [WaitFor wtime] w +---- | otherwise -> replaceAction [MeleeAttack (x-1)] w +---- (TrackYou:_) -> addGoal [[WaitFor wtime,PathTo ypos]] $ set randGen g1 w +---- (InitTrackYou:_)| canSeeIndirect cid (_yourID w) w -> replaceGoal [[TrackYou]] w +---- | otherwise -> w +---- (Guard p p':_) | canSeeIndirect cid (_yourID w) w +---- -> addGoal [[WaitFor wtime,PathTo ypos]] $ set randGen g1 w +---- | dist cpos p > 10 +---- -> addGoal [[PathTo p]] w +---- | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 +---- -> turnTowardSpeed 0.05 p' cid w +---- | otherwise -> w +---- (InitGuard :_) -> replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] w + +-- be aware that the crit can be removed -- don't just refer to its id in the +-- world->world part +miniAI :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +miniAI w (f,g) cr = + let cpos = _crPos cr + cid = _crID cr + ypos = _crPos $ you w + wp = _crInv cr IM.! _crInvSel cr + (aimtime,g1) = randomR (80,120) g + noAmmo = 0 == _wpLoadedAmmo wp + turnCloseSlow p | errorAngleVV 22 (p -.- cpos) + (unitVectorAtAngle (_crDir cr)) < 0.4 + = crTurnTowardSpeed 0.01 p + | otherwise = crTurnTowardSpeed 0.05 p + replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs) + addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ gs) + replaceAction newActions + = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) + addAction newActions + = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) +-- autoFireTweak p | _wpIsAuto wp = Just +-- | otherwise = replaceGoal [[AimAt p (_wpFireRate wp * 2)]] + in --if _crHP cr <= 0 then killCr w f cr else + case head $ _goals $ _crState cr of + [] | canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | otherwise -> ( ( f , g ) + , replaceGoal [] cr + ) + (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | x == 0 -> ( (f ,g ), replaceAction [] cr ) + | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) + (MoveToFor p x:gls) + | canSeeFire cpos ypos w -> ( (f , g1) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | x == 0 -> ( (f , g) + , replaceAction [] cr + ) + | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr) + | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 + -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) + | otherwise -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 + $ crTurnTowardSpeed 0.05 p cr ) + (PathTo p:_) | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr ) + | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) + | otherwise -> case pointTowardsGoal cpos p w of + Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) + _ -> ( (f , g) , replaceAction [] cr ) + (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) + , replaceGoal [[Reload + ,PathTo p + ,WaitFor 50 + --,Search 1 ,WaitFor 100 + ]] + cr + ) + | canSeeFireVisionAll cid (_yourID w) w + -> ( (tryUseItem cid . f , g) + , replaceGoal [[FireAt ypos]] $ turnCloseSlow p cr + ) + | pathToPointFireable cid p w + -> ( (tryUseItem cid . f , g) + , Just $ turnCloseSlow p cr + ) + | otherwise -> ( (f , g) + , replaceGoal [[PathTo p,WaitFor 50 ]] cr + ) + (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) + | canSeeFireVisionAny cid (_yourID w) w + -> ( (f , g) + , Just $ turnCloseSlow ypos cr + ) -- no longer chase if see you when reloading + -- $ replaceAction [] w + | otherwise -> ( (f , g) , Just cr) + (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) + | otherwise + -> ( ( f , g1) + , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) + , Search (i-1) + ] cr + ) + (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w + -> ( ( f , g1) + , addGoal [[AimAt ypos (0)]] cr + ) + | dist cpos p > 10 + -> ( (f,g) , addGoal [[PathTo p]] cr) + | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 + -> ( (f,g) + ,Just $ crTurnTowardSpeed 0.05 p' cr) + | otherwise -> ( (f,g) ,Just cr) + (InitGuard :_) -> ( (f,g) + ,replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr + ) + (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) + | canSeeFireVisionAll cid (_yourID w) w + -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ turnCloseSlow p cr) + | otherwise + -> ( (f,g) , replaceAction [AimAt p (i-1)] $ turnCloseSlow p cr) + +strafeOrChargeAI :: Float -> Float -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +strafeOrChargeAI inRange outRange w (f,g) cr = + let cpos = _crPos cr + cid = _crID cr + ypos = _crPos $ you w + wp = _crInv cr IM.! _crInvSel cr + (aimtime,g1) = randomR (80,120) g + noAmmo = 0 == _wpLoadedAmmo wp + inR p aRange = dist p cpos < aRange + inA p = errorAngleVV 22 (p -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.2 + inA' p = errorAngleVV 22 (p -.- cpos) (unitVectorAtAngle (_crDir cr)) < pi/2 + strafeClockwise p | dist cpos p > 200 = crTurnTowardSpeed 0.05 p . crMvForward 3 + | dist cpos p < 80 = crTurnTowardSpeed 0.05 p . crMvForward (-3) + | errorAngleVV 22 (p' -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4 + = crTurnTowardSpeed 0.01 p' . crStrafeLeft 3 + | otherwise + = crTurnTowardSpeed 0.05 p' . crStrafeLeft 3 + where v = vNormal $ p -.- cpos + p' = p +.+ 0.5 *.* (v -.- 20 *.* (normalizeV v)) + strafeCloseSlow p | dist cpos p > 200 = crTurnTowardSpeed 0.05 p . crMvForward 3 + | dist cpos p < 80 = crTurnTowardSpeed 0.05 p . crMvForward (-3) + | errorAngleVV 22 (p' -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4 + = crTurnTowardSpeed 0.01 p' . crStrafeLeft 3 + | otherwise + = crTurnTowardSpeed 0.05 p' . crStrafeLeft 3 + where v = vNormal $ p -.- cpos + p' = p +.+ 0.5 *.* (v -.- 20 *.* (normalizeV v)) + replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs) + addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ gs) + replaceAction newActions + = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) + addAction newActions + = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) +-- autoFireTweak p | _wpIsAuto wp = Just +-- | otherwise = replaceGoal [[AimAt p (_wpFireRate wp * 2)]] + in --if _crHP cr <= 0 then killCr w f cr else + case head $ _goals $ _crState cr of + [] | canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | otherwise -> ( ( f , g ) + , replaceGoal [] cr + ) + (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] + cr + ) + | x == 0 -> ( (f ,g ), replaceAction [] cr ) + | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) + (MoveToFor p x:gls) + | canSeeFire cpos ypos w -> ( (f , g1) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | x == 0 -> ( (f , g) + , replaceAction [] cr + ) + | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr) + | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 + -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) + | otherwise -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 + $ crTurnTowardSpeed 0.05 p cr ) + (PathTo p:_) | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr ) + | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) + | otherwise -> case pointTowardsGoal cpos p w of + Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) + _ -> ( (f , g) , replaceAction [] cr ) + (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) + , replaceGoal [[Reload + ,PathTo p + ,WaitFor 50 + --,Search 1 ,WaitFor 100 + ]] + cr + ) + | canSeeFireVisionAll cid (_yourID w) w + -> ( (tryUseItem cid . f , g) + , replaceGoal [[FireAt ypos]] $ strafeCloseSlow p cr + ) + | pathToPointFireable cid p w + -> ( (tryUseItem cid . f , g) + , Just $ strafeCloseSlow p cr + ) + | otherwise -> ( (f , g) + , replaceGoal [[PathTo p,WaitFor 50 ]] cr + ) + (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) + | canSeeFireVisionAny cid (_yourID w) w + -> ( (f , g) + , Just $ strafeCloseSlow ypos cr + ) -- no longer chase if see you when reloading + -- $ replaceAction [] w + | otherwise -> ( (f , g) , Just cr) + (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) + | otherwise + -> ( ( f , g1) + , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) + , Search (i-1) + ] cr + ) + (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w + -> ( ( f , g1) + , addGoal [[AimAt ypos (2*aimtime)]] cr + ) + | dist cpos p > 10 + -> ( (f,g) , addGoal [[PathTo p]] cr) + | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 + -> ( (f,g) + ,Just $ crTurnTowardSpeed 0.05 p' cr) + | otherwise -> ( (f,g) ,Just cr) + (InitGuard :_) -> ( (f,g) + ,replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr + ) + (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) + | canSeeFireVisionAll cid (_yourID w) w + -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ strafeCloseSlow p + cr + ) + | otherwise + -> ( (f,g) , replaceAction [AimAt p (i-1)] $ strafeCloseSlow p cr) + +chargeAI :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +chargeAI w (f,g) cr = + let cpos = _crPos cr + cid = _crID cr + ypos = _crPos $ you w + (aimtime,g') = randomR (80,120::Float) g + wp = _crInv cr IM.! _crInvSel cr + fTurn p | errorAngleVV 22 (p -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4 + = crTurnTowardSpeed 0.005 p + | errorAngleVV 22 (p -.- cpos) (unitVectorAtAngle (_crDir cr)) < 1 + = crTurnTowardSpeed 0.05 p + | otherwise + = crTurnTowardSpeed 0.2 p + noAmmo = 0 == _wpLoadedAmmo wp + updateSearch = over (crState . goals) f + where f (g:_:h:gs) = (g:[PathTo ypos]:h:gs) + f (g:gs) = (g:[PathTo ypos]:gs) + replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs) + addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ gs) + replaceAction newActions + = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) + addAction newActions + = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) + in --if _crHP cr <= 0 then killCr w f cr else + case head $ _goals $ _crState cr of + (MoveTo p:_) + | dist cpos ypos < 40 -> ((f,g) , replaceAction [Fire] cr) + | canSeeFire cpos ypos w -> ((f,g), Just . crMvBy (3,0) . fTurn ypos $ cr) + | otherwise -> ((f,g), Just . crMvBy (3,0) . fTurn p $ cr) + (Fire:_) + | dist cpos ypos < 60 && canSeeFire cpos ypos w + -> ((tryUseItem cid . f,g), Just $ fTurn ypos cr) + | otherwise -> ((f,g), replaceAction [] cr) + [] | canSeeFireVisionAny cid (_yourID w) w + -> ( ( f , g' ) , addAction [MoveTo ypos] cr) + | otherwise -> ( ( f , g' ) , Just cr) + (WaitFor x:gls)| x == 0 -> ( (f ,g' ), replaceAction [] cr ) + | otherwise -> ( (f ,g' ), replaceAction [WaitFor (x-1)] cr ) + (MoveToFor p x:gls) + | canSeeFire cpos ypos w -> ( (f , g') + , replaceAction [MoveTo ypos] cr + ) + | x == 0 -> ( (f , g') + , replaceAction [] cr + ) + | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr) + | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 + -> ( (f , g') + , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) + | otherwise -> ( (f , g') + , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 + $ crTurnTowardSpeed 0.05 p cr ) + (PathTo p:_) | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr ) + | hasLOS cpos p w -> ( (f , g') , addAction [MoveToFor p 100] cr ) + | otherwise -> case pointTowardsGoal cpos p w of + Just q -> ( (f , g') , addAction [MoveToFor q 100] cr ) + _ -> ( (f , g') , replaceAction [] cr ) + (Init:_) -> ((f,g), replaceAction [] cr) + +launcherAI :: Float -> Float -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +launcherAI inRange outRange w (f,g) cr = + let cpos = _crPos cr + cid = _crID cr + ypos = _crPos $ you w + yposl x = ypos -.- x *.* (vNormal $ normalizeV $ ypos -.- cpos) + yposr x = ypos +.+ x *.* (vNormal $ normalizeV $ ypos -.- cpos) + (aimtime,g') = randomR (80,120) g + (recupTime,_) = randomR (0,50) g + wp = _crInv cr IM.! _crInvSel cr + noAmmo = 0 == _wpLoadedAmmo wp || _wpReloadState wp /= 0 + updateSearch = over (crState . goals) f + where f (g:_:h:gs) = (g:[PathTo ypos]:h:gs) + f (g:gs) = (g:[PathTo ypos]:gs) + replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs) + addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ gs) + replaceAction newActions + = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) + addAction newActions + = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) + ts = take 3 $ randomRs (20,25) g + retreatActions = SetPosture Aiming + : Fire + : TurnByFor 0.16 20 + : SetPosture AtEase + : MoveByFor (3,0) 18 + : SetPosture Aiming + : Fire + : TurnByFor (-0.16) 20 + : SetPosture AtEase + : MoveByFor (3,0) 10 + : TurnToward ypos + -- : WaitFor 12 + -- : Fire + -- : WaitFor 20 + : SetPosture Aiming + : Fire + : WaitFor 60 + : [SetPosture AtEase] + strafeLeftActions = TurnToward (yposr 30) + : SetPosture Aiming + : (concatMap (\t -> [Fire,MoveByFor (0,3) t]) ts) + ++ [SetPosture AtEase] + strafeRightActions = TurnToward (yposl 30) + : SetPosture Aiming + : (concatMap (\t -> [Fire,MoveByFor (0,-3) t]) ts) + ++ [SetPosture AtEase] + rota a = cpos +.+ rotateV a (ypos -.- cpos) + (a2:a3:a4:a5:_) = evalState (takeOne [[0.1,0.15,0.5,1.5] + --,[0.1,0.15,0.5,1.5] + -- ,[0.2,0.3,0.6,1] + -- ,[0.2,0.3,0.5,0.8] + -- ,[0.2,0.3,0.5,1] + -- ,[0.1,0.2,0.5,0.9] + -- ,[0.1,0.2,0.4,0.7] + -- ,[0.1,0.2,0.3,0.4] + ] + ) g + curveLeft = TurnToward (rota $ negate a2) + : SetPosture Aiming + : Fire + : TurnToward (rota $ negate a3) + : WaitFor 20 + : Fire + : TurnToward (rota $ negate a4) + : WaitFor 20 + : Fire + : TurnToward (rota $ negate a5) + : SetPosture AtEase + : [MoveByFor (-3,0) 40] + curveRight = TurnToward (rota a2) + : SetPosture Aiming + : Fire + : TurnToward (rota a3) + : WaitFor 20 + : Fire + : TurnToward (rota a4) + : WaitFor 20 + : Fire + : TurnToward (rota a5) + : SetPosture AtEase + : [MoveByFor (-3,0) 40] + strafeProb :: Float + strafeProb | dist cpos ypos > 350 = 40 + | otherwise = 10 + retreatProb | dist cpos ypos < 100 = 80 + | dist cpos ypos < 200 = 40 + | otherwise = 0 + curveLeftProb = 20 + curveRightProb = 20 + -- | dist cpos ypos < 200 = 1 + -- | otherwise = 0 + fireActions = -- TurnToward ypos : + (evalState (takeOneWeighted + [curveLeftProb,curveRightProb + ,strafeProb,strafeProb,retreatProb] + [curveLeft + ,curveRight + ,strafeLeftActions + ,strafeRightActions + ,retreatActions + ] + ) $ g + ) + in --if _crHP cr <= 0 then killCr w f cr else + case head $ _goals $ _crState cr of + (TurnTo p:_) -> ( (f,g') , replaceAction [] . crTurnTo p $ cr) + (TurnByFor a 0:_) -> ( (f,g') , replaceAction [] . over crDir (+a) $ cr) + (TurnByFor a i:_) -> ( (f,g') , replaceAction [TurnByFor a (i-1)] . over crDir (+a) $ cr) + (SetPosture pture:_) -> ((f,g), replaceAction [] $ set (crState . stance . posture) pture cr) + (MoveByFor p 0:_) -> ((f,g'), replaceAction [] . crMvBy p $ cr) + (MoveByFor p i:_) -> ((f,g'), replaceAction [MoveByFor p (i-1)] . crMvBy p $ cr) + (Fire:_) | collidePointWallsSimple cpos (cpos +.+ 40 *.* unitVectorAtAngle (_crDir cr)) + (wallsAlongLine cpos (cpos +.+ 40 *.* unitVectorAtAngle (_crDir cr)) w) + -> ((f,g),replaceAction [] cr) + | otherwise -> ((tryUseItem cid . f,g'), replaceAction [] cr) + (GoalID i (MoveByFor p 0):_) -> ((f,g'), replaceAction [] . crMvBy p $ cr) + (GoalID i (MoveByFor p x):_) + | canSeeFire cpos (aCrPos i w) w + -> ( (f,g') + , replaceAction [GoalID i (MoveByFor p (x-1))] + . crMvBy p + . crTurnTowardSpeed 0.01 (aCrPos i w) + $ cr + ) + | otherwise + -> ( (f,g') + , replaceAction [GoalID i (MoveForwardFor (x-1))] + . crMvBy p + $ cr + ) + (TurnToward p:_) + | errorAngleVV 99 (p -.- cpos) (unitVectorAtAngle $ _crDir cr) > 2 + -> ( (f,g') + , Just . crTurnTowardSpeed 0.5 p + $ cr + ) + | errorAngleVV 99 (p -.- cpos) (unitVectorAtAngle $ _crDir cr) > 0.2 + -> ( (f,g') + , Just . crTurnTowardSpeed 0.1 p + $ cr + ) + | otherwise + -> ( (f,g') + , replaceAction [] + . crTurnTo p + $ cr + ) + [] | noAmmo -> ( (tryUseItem cid . f, g') + , addAction [Reload] cr + ) + | canSeeFireVisionAny cid (_yourID w) w + -> ( ( f , g' ) + -- , addAction (WaitFor 9:fireActions) + , addAction (WaitFor 9:fireActions) + $ updateSearch cr + ) + | otherwise -> ( ( f , g' ) + , replaceGoal [] cr + ) + (WaitFor x:gls)| x == 0 -> ( (f ,g' ), replaceAction [] cr ) + | otherwise -> ( (f ,g' ), replaceAction [WaitFor (x-1)] cr ) + (MoveToFor p x:gls) + | canSeeFire cpos ypos w -> ( (f , g') + , replaceGoal [[],[PathTo ypos]] cr + ) + | x == 0 -> ( (f , g') + , replaceAction [] cr + ) + | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr) + | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 + -> ( (f , g') + , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) + | otherwise -> ( (f , g') + , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 + $ crTurnTowardSpeed 0.05 p cr ) + (PathTo p:_) | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr ) + | hasLOS cpos p w -> ( (f , g') , addAction [MoveToFor p 100] cr ) + | otherwise -> case pointTowardsGoal cpos p w of + Just q -> ( (f , g') , addAction [MoveToFor q 100] cr ) + _ -> ( (f , g') , replaceAction [] cr ) + (Reload:_) | _wpReloadState wp == 0 -> ( (f , g') , replaceAction [WaitFor recupTime] cr ) + | canSeeFireVisionAny cid (_yourID w) w + -> ( (f , g') + , Just $ cr + ) -- no longer chase if see you when reloading + -- $ replaceAction [] w + | otherwise -> ( (f , g') , Just cr) + (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w + -> ( ( f , g') + , addGoal [[WaitFor aimtime],[PathTo ypos]] cr + ) + | dist cpos p > 10 + -> ( (f,g') , addGoal [[PathTo p]] cr) + | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 + -> ( (f,g') + ,Just $ crTurnTowardSpeed 0.05 p' cr) + | otherwise -> ( (f,g') ,Just cr) + (Init :_) -> ( (f,g') + ,replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr + ) +dodgeAI :: Float -> Float -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +dodgeAI inRange outRange w (f,g) cr = + let cpos = _crPos cr + cid = _crID cr + ypos = _crPos $ you w + yposl x = ypos -.- x *.* (vNormal $ normalizeV $ ypos -.- cpos) + yposr x = ypos +.+ x *.* (vNormal $ normalizeV $ ypos -.- cpos) + (aimtime,g') = randomR (0,120) g + (recupTime,_) = randomR (0,50) g + wp = _crInv cr IM.! _crInvSel cr + noAmmo = 0 == _wpLoadedAmmo wp + updateSearch = over (crState . goals) f + where f (g:_:h:gs) = (g:[PathTo ypos]:h:gs) + f (g:gs) = (g:[PathTo ypos]:gs) + replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs) + addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ gs) + replaceAction newActions + = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) + addAction newActions + = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) + retreatOffset = let a | dist cpos ypos < 50 = 0 + | isLeftOfA (_crDir cr) (argV $ ypos -.- cpos) + = -0.7 + | otherwise = 0.7 + in fromMaybe ypos + $ intersectLineLine' cpos + (cpos +.+ rotateV a (ypos -.- cpos)) + ypos + (ypos +.+ vNormal (cpos -.- ypos)) + ts = take 5 $ randomRs (7,10) g + chargeActions = TurnToward ypos + : (GoalID 0 (MoveByFor (3,0) 15)) + : (concatMap (\t -> [GoalID 0 (MoveByFor (3,0) t),Fire]) ts) + retreatActions = TurnToward retreatOffset + :(GoalID 0 (MoveByFor (-3,0) 9)) + : (concatMap (\t -> [GoalID 0 (MoveByFor (-3,0) t),Fire]) ts) + strafeLeftActions = TurnToward (yposr 150) : MoveByFor (0,3) 4 + : (concatMap (\t -> [MoveByFor (0,3) t,Fire]) ts) + strafeRightActions = TurnToward (yposl 150) : MoveByFor (0,-3) 4 + : (concatMap (\t -> [MoveByFor (0,-3) t,Fire]) ts) + chargeProb :: Float + chargeProb | dist cpos ypos > 300 = 5 + | dist cpos ypos > 150 = 1 + | otherwise = 0 + strafeProb | dist cpos ypos > 150 = 1 + | otherwise = 0 + retreatProb | dist cpos ypos < 200 = 1 + | otherwise = 0 + fireActions = -- TurnToward ypos : + (evalState (takeOneWeighted + [chargeProb,retreatProb,strafeProb,strafeProb] + [chargeActions + ,retreatActions + ,strafeLeftActions + ,strafeRightActions + ] + ) $ g + ) + in --if _crHP cr <= 0 then killCr w f cr else + case head $ _goals $ _crState cr of + (MoveByFor p 0:_) -> ((f,g'), replaceAction [] . crMvBy p $ cr) + (MoveByFor p i:_) -> ((f,g'), replaceAction [MoveByFor p (i-1)] . crMvBy p $ cr) + (Fire:_) -> ((tryUseItem cid . f,g'), replaceAction [] cr) + (GoalID i (MoveByFor p 0):_) -> ((f,g'), replaceAction [] . crMvBy p $ cr) + (GoalID i (MoveByFor p x):_) + | canSeeFire cpos (aCrPos i w) w + -> ( (f,g') + , replaceAction [GoalID i (MoveByFor p (x-1))] + . crMvBy p + . crTurnTowardSpeed 0.01 (aCrPos i w) + $ cr + ) + | otherwise + -> ( (f,g') + , replaceAction [GoalID i (MoveByFor p (x-1))] + . crMvBy p $ cr + ) + (TurnToward p:_) + | errorAngleVV 99 (p -.- cpos) (unitVectorAtAngle $ _crDir cr) > 2 + -> ( (f,g') + , Just . crTurnTowardSpeed 0.2 p + $ cr + ) + | errorAngleVV 99 (p -.- cpos) (unitVectorAtAngle $ _crDir cr) > 0.2 + -> ( (f,g') + , Just . crTurnTowardSpeed 0.1 p + $ cr + ) + | otherwise + -> ( (f,g') + , replaceAction [] + $ cr + ) + [] | noAmmo -> ( (tryUseItem cid . f, g') , addAction [Reload] cr) + | canSeeFireVisionAny cid (_yourID w) w + -> ( ( f , g' ) , addAction (WaitFor 9:fireActions) $ updateSearch cr) + | otherwise -> ( ( f , g' ) , replaceGoal [] cr) + (WaitFor x:gls)| x == 0 -> ( (f ,g' ), replaceAction [] cr ) + | otherwise -> ( (f ,g' ), replaceAction [WaitFor (x-1)] + $ crTurnTowardSpeed 0.05 ypos cr ) + (MoveToFor p x:gls) + | canSeeFire cpos ypos w -> ( (f , g') + , replaceGoal [[],[PathTo ypos]] cr + ) + | x == 0 -> ( (f , g') + , replaceAction [] cr + ) + | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr) + | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 + -> ( (f , g') + , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) + | otherwise -> ( (f , g') + , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 + $ crTurnTowardSpeed 0.05 p cr ) + (PathTo p:_) | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr ) + | hasLOS cpos p w -> ( (f , g') , addAction [MoveToFor p 100] cr ) + | otherwise -> case pointTowardsGoal cpos p w of + Just q -> ( (f , g') , addAction [MoveToFor q 100] cr ) + _ -> ( (f , g') , replaceAction [] cr ) + (Reload:_) | _wpReloadState wp == 0 -> ( (f , g') , replaceAction [WaitFor recupTime] cr ) + | otherwise -> ( (f , g') , Just cr) + (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w + -> ( ( f , g') + , addGoal [[WaitFor aimtime],[PathTo ypos]] cr + ) + | dist cpos p > 10 + -> ( (f,g') , addGoal [[PathTo p]] cr) + | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 + -> ( (f,g') + ,Just $ crTurnTowardSpeed 0.05 p' cr) + | otherwise -> ( (f,g') ,Just cr) + (InitGuard :_) -> ( ( f,g') +-- (InitGuard :_) -> ( (over lightSources (IM.insert cid (crLight cid)) . f,g') + ,replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr + ) + (x:_) -> error $ "missing the following pattern in case expression:" ++ show x + +logistic :: Float -> Float -> Float -> (Float -> Float) +logistic x0 l k x = l / (1 + exp (k*(x0 - x))) + + +circleClockwiseAI :: Float -> Float -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +circleClockwiseAI inRange outRange w (f,g) cr = + let cpos = _crPos cr + cid = _crID cr + ypos = _crPos $ you w + wp = _crInv cr IM.! _crInvSel cr + (aimtime,g1) = randomR (80,120) g + noAmmo = 0 == _wpLoadedAmmo wp + inR p aRange = dist p cpos < aRange + inA p = errorAngleVV 22 (p -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.2 + inA' p = errorAngleVV 22 (p -.- cpos) (unitVectorAtAngle (_crDir cr)) < pi/2 + strafeCloseSlow p | dist cpos p > 200 = crTurnTowardSpeed 0.05 p . crMvForward 3 + | dist cpos p < 80 = crTurnTowardSpeed 0.05 p . crMvForward (-3) + | errorAngleVV 22 (p' -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4 + = crTurnTowardSpeed 0.01 p' . crStrafeLeft 3 + | otherwise + = crTurnTowardSpeed 0.05 p' . crStrafeLeft 3 + where v = vNormal $ p -.- cpos + p' = p +.+ 0.5 *.* (v -.- 20 *.* (normalizeV v)) + replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs) + addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ gs) + replaceAction newActions + = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) + addAction newActions + = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) +-- autoFireTweak p | _wpIsAuto wp = Just +-- | otherwise = replaceGoal [[AimAt p (_wpFireRate wp * 2)]] + in --if _crHP cr <= 0 then killCr w f cr else + case head $ _goals $ _crState cr of + [] | canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | otherwise -> ( ( f , g ) + , replaceGoal [] cr + ) + (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] + cr + ) + | x == 0 -> ( (f ,g ), replaceAction [] cr ) + | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) + (MoveToFor p x:gls) + | canSeeFire cpos ypos w -> ( (f , g1) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | x == 0 -> ( (f , g) + , replaceAction [] cr + ) + | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr) + | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 + -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) + | otherwise -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 + $ crTurnTowardSpeed 0.05 p cr ) + (PathTo p:_) | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr ) + | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) + | otherwise -> case pointTowardsGoal cpos p w of + Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) + _ -> ( (f , g) , replaceAction [] cr ) + (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) + , replaceGoal [[Reload + ,PathTo p + ,WaitFor 50 + --,Search 1 ,WaitFor 100 + ]] + cr + ) + | canSeeFireVisionAll cid (_yourID w) w + -> ( (tryUseItem cid . f , g) + , replaceGoal [[FireAt ypos]] $ strafeCloseSlow p cr + ) + | pathToPointFireable cid p w + -> ( (tryUseItem cid . f , g) + , Just $ strafeCloseSlow p cr + ) + | otherwise -> ( (f , g) + , replaceGoal [[PathTo p,WaitFor 50 ]] cr + ) + (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) + | canSeeFireVisionAny cid (_yourID w) w + -> ( (f , g) + , Just $ strafeCloseSlow ypos cr + ) -- no longer chase if see you when reloading + -- $ replaceAction [] w + | otherwise -> ( (f , g) , Just cr) + (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) + | otherwise + -> ( ( f , g1) + , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) + , Search (i-1) + ] cr + ) + (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w + -> ( ( f , g1) + , addGoal [[AimAt ypos (2*aimtime)]] cr + ) + | dist cpos p > 10 + -> ( (f,g) , addGoal [[PathTo p]] cr) + | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 + -> ( (f,g) + ,Just $ crTurnTowardSpeed 0.05 p' cr) + | otherwise -> ( (f,g) ,Just cr) + (InitGuard :_) -> ( (f,g) + ,replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr + ) + (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) + | canSeeFireVisionAll cid (_yourID w) w + -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ strafeCloseSlow p + cr + ) + | otherwise + -> ( (f,g) , replaceAction [AimAt p (i-1)] $ strafeCloseSlow p cr) + +twitchMissAI :: Float -> Float -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +twitchMissAI inRange outRange w (f,g) cr = + let cpos = _crPos cr + yposl = ypos +.+ 25 *.* normalizeV (vNormal (cpos -.- ypos)) + yposr = ypos -.- 25 *.* normalizeV (vNormal (cpos -.- ypos)) + yposoff = evalState (takeOne [yposl,yposr]) $ _randGen w + cid = _crID cr + ypos = _crPos $ you w + wp = _crInv cr IM.! _crInvSel cr + fireRate = fromMaybe 0 $ wp ^? wpFireRate + noAmmo = 0 == _wpLoadedAmmo wp + strafeCloseSlow p | errorAngleVV 22 (p -.- cpos) + (unitVectorAtAngle (_crDir cr)) < 0.1 + = crTurnTowardSpeed 0.01 p . crMvForward closeDist + | otherwise + = crTurnAndStrafeIn inOrOut 0.05 p + where inOrOut | dist p cpos < inRange = -1 + | dist p cpos < outRange = 0 + | otherwise = 1 + closeDist | dist p cpos < inRange = -1 + | dist p cpos < outRange = 0 + | otherwise = 1 + replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs) + addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ gs) + replaceAction newActions + = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) + addAction newActions + = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) + (t,g') = randomR (fireRate+10,fireRate+15) g + retreatPs = sortBy (compare `on` dist cpos) $ map f $ nRaysRad 8 400 + where f p = fromMaybe (ypos +.+ p) $ fmap fst + $ collidePointWalls ypos (ypos +.+ p) (wallsAlongLine ypos (ypos +.+ p) w) + retreatP' = cpos +.+ 300 *.* (cpos -.- ypos) + retreatP'' = fromMaybe retreatP' $ fmap fst + $ collidePointWalls ypos retreatP' + $ wallsAlongLine ypos retreatP' w + retreatP = head $ sortBy (compare `on` (\p -> dist p ypos < 300)) $ retreatP'' : retreatPs + fireActions = [TurnToward yposoff, Fire, TurnTo ypos, WaitFor t + ,Fire,Fire,Reload,GoalID 0 (WaitFor 20),MakeJudgement] + fleeActions = [MoveToFor retreatP 50,MakeJudgement] + in --if _crHP cr <= 0 then killCr w f cr else + case head $ _goals $ _crState cr of + [] -> ((f,g), replaceGoal [] cr) + (MakeJudgement:_) + | not (canSeeFire cpos ypos w) -> ((f,g),replaceAction [] cr) + | dist cpos ypos > 400 -> ((f,g), replaceAction [MoveToFor ypos 20] cr) + | dist cpos ypos < 150 -> ((f,g'),replaceAction fleeActions $ crMvBy (3,0) cr) + | otherwise -> ((f,g'),replaceAction fireActions cr) + (GoalID i (WaitFor x):gls) + | x == 0 -> ( (f ,g' ), replaceAction [] cr ) + | otherwise -> ( (f ,g' ), replaceAction [GoalID i (WaitFor (x-1))] + $ strafeCloseSlow ypos cr ) + (WaitFor x:gls)| x == 0 -> ( (f ,g' ), replaceAction [] cr ) + | otherwise -> ( (f ,g' ), replaceAction [WaitFor (x-1)] cr ) + (MoveToFor p x:gls) + | x == 0 -> ( (f, g') , replaceAction [] cr) + | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr) + | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 + -> ( (f , g') + , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.5 p cr ) + | otherwise -> ( (f , g') + , replaceAction [MoveToFor p (x-1)] $ crMvForward 3 + $ crTurnTowardSpeed 0.05 p cr ) + (PathTo p:_) + | canSeeFire cpos ypos w -> ((f,g),replaceGoal [[MakeJudgement]] cr) + | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr ) + | hasLOS cpos p w -> ( (f , g') , addAction [MoveToFor p 50] cr ) + | otherwise -> case pointTowardsGoal cpos p w of + Just q -> ( (f , g') , addAction [MoveToFor q 50] cr ) + _ -> ( (f , g') , replaceAction [] cr ) + (Fire:gls) -> ( (tryUseItem cid . f , g' ) + , replaceAction [] cr + ) + (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g') , replaceAction [] cr ) + | canSeeFireVisionAny cid (_yourID w) w + -> ( (f , g') + , Just $ strafeCloseSlow ypos cr + ) -- no longer chase if see you when reloading + -- $ replaceAction [] w + | otherwise -> ( (f , g) , Just cr) + (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w + -> ( ( f , g') + , addGoal [[MakeJudgement]] cr + ) + | dist cpos p > 10 + -> ( (f,g) , addGoal [[PathTo p]] cr) + | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 + -> ( (f,g) + ,Just $ crTurnTowardSpeed 0.05 p' cr) + | otherwise -> ( (f,g) ,Just cr) + (InitGuard :_) -> ( (f,g) + ,replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr + ) + (TurnToward p:_) + | errorAngleVV 99 (p -.- cpos) (unitVectorAtAngle $ _crDir cr) > 2 + -> ( (f,g') , Just . crTurnTowardSpeed 0.2 p $ cr) + | errorAngleVV 99 (p -.- cpos) (unitVectorAtAngle $ _crDir cr) > 0.2 + -> ( (f,g') , Just . crTurnTowardSpeed 0.1 p $ cr) + | otherwise + -> ( (f,g') , replaceAction [] . crTurnTo p $ cr) + (TurnTo p:_) -> ( (f,g') , replaceAction [] . crTurnTo p $ cr) + +closeToRangeAI :: Float -> Float -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +closeToRangeAI inRange outRange w (f,g) cr = + let cpos = _crPos cr + cid = _crID cr + ypos = _crPos $ you w + wp = _crInv cr IM.! _crInvSel cr + fireRate = fromMaybe 0 $ wp ^? wpFireRate + (aimtime,g1) = randomR (80,120) g + noAmmo = 0 == _wpLoadedAmmo wp + strafeCloseSlow p | errorAngleVV 22 (p -.- cpos) + (unitVectorAtAngle (_crDir cr)) < 0.1 + = crTurnTowardSpeed 0.01 p . crMvForward closeDist + | otherwise + = crTurnAndStrafeIn inOrOut 0.05 p + where inOrOut | dist p cpos < inRange = -1.5 + | dist p cpos < outRange = 0 + | otherwise = 1.5 + closeDist | dist p cpos < inRange = -1.5 + | dist p cpos < outRange = 0 + | otherwise = 1.5 + replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs) + addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ gs) + replaceAction newActions + = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) + addAction newActions + = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) + in --if _crHP cr <= 0 then killCr w f cr else + case head $ _goals $ _crState cr of + [] | canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | otherwise -> ( ( f , g ) + , replaceGoal [] cr + ) + (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] + cr + ) + | x == 0 -> ( (f ,g ), replaceAction [] cr ) + | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) + (MoveToFor p x:gls) + | canSeeFire cpos ypos w -> ( (f , g1) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | x == 0 -> ( (f , g) + , replaceAction [] cr + ) + | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr) + | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 + -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) + | otherwise -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crMvForward 3 + $ crTurnTowardSpeed 0.05 p cr ) + (PathTo p:_) | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr ) + | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) + | otherwise -> case pointTowardsGoal cpos p w of + Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) + _ -> ( (f , g) , replaceAction [] cr ) + (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) + , replaceGoal [[Reload + ,PathTo p + ,WaitFor 50 + --,Search 1 ,WaitFor 100 + ]] + cr + ) + | canSeeFireVisionAll cid (_yourID w) w + -> ( (tryUseItem cid . f , g) + , replaceGoal [[AimAt ypos (fireRate+ aimtime - 80)]] + $ strafeCloseSlow p cr + ) + | pathToPointFireable cid p w + -> ( (tryUseItem cid . f , g) + , Just $ strafeCloseSlow p cr + ) + | otherwise -> ( (f , g) + , replaceGoal [[PathTo p,WaitFor 50 ]] cr + ) + (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) + | canSeeFireVisionAny cid (_yourID w) w + -> ( (f , g) + , Just $ strafeCloseSlow ypos cr + ) -- no longer chase if see you when reloading + -- $ replaceAction [] w + | otherwise -> ( (f , g) , Just cr) + (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) + | otherwise + -> ( ( f , g1) + , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) + , Search (i-1) + ] cr + ) + (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w + -> ( ( f , g1) + , addGoal [[AimAt ypos (2*aimtime)]] cr + ) + | dist cpos p > 10 + -> ( (f,g) , addGoal [[PathTo p]] cr) + | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 + -> ( (f,g) + ,Just $ crTurnTowardSpeed 0.05 p' cr) + | otherwise -> ( (f,g) ,Just cr) + (InitGuard :_) -> ( (f,g) + ,replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr + ) + (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) + | canSeeFireVisionAll cid (_yourID w) w + -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ strafeCloseSlow p + cr + ) + | otherwise + -> ( (f,g) , replaceAction [AimAt p (i-1)] $ strafeCloseSlow p cr) + +suppressShooterAI :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +suppressShooterAI w (f,g) cr = + let cpos = _crPos cr + cid = _crID cr + ypos = _crPos $ you w + wp = _crInv cr IM.! _crInvSel cr + (aimtime,g1) = randomR (80,120) g + noAmmo = 0 == _wpLoadedAmmo wp + turnCloseSlow p | errorAngleVV 22 (p -.- cpos) + (unitVectorAtAngle (_crDir cr)) < 0.4 + = crTurnTowardSpeed 0.01 p + | otherwise = crTurnTowardSpeed 0.05 p + replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs) + addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ gs) + replaceAction newActions + = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) + addAction newActions + = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) +-- autoFireTweak p | _wpIsAuto wp = Just +-- | otherwise = replaceGoal [[AimAt p (_wpFireRate wp * 2)]] + in --if _crHP cr <= 0 then killCr w f cr else + case head $ _goals $ _crState cr of + [] | canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | otherwise -> ( ( f , g ) + , replaceGoal [] cr + ) + (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | x == 0 -> ( (f ,g ), replaceAction [] cr ) + | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) + (MoveToFor p x:gls) + | canSeeFire cpos ypos w -> ( (f , g1) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | x == 0 -> ( (f , g) + , replaceAction [] cr + ) + | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr) + | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 + -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) + | otherwise -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 + $ crTurnTowardSpeed 0.05 p cr ) + (PathTo p:_) | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr ) + | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) + | otherwise -> case pointTowardsGoal cpos p w of + Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) + _ -> ( (f , g) , replaceAction [] cr ) + (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) + , replaceGoal [[Reload + ,PathTo p + ,WaitFor 50 + --,Search 1 ,WaitFor 100 + ]] + cr + ) + | canSeeFireVisionAll cid (_yourID w) w + -> ( (tryUseItem cid . f , g) + , replaceGoal [[FireAt ypos]] $ turnCloseSlow p cr + ) + | pathToPointFireable cid p w + -> ( (tryUseItem cid . f , g) + , Just $ turnCloseSlow p cr + ) + | otherwise -> ( (f , g) + , replaceGoal [[PathTo p,WaitFor 50 ]] cr + ) + (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) + | canSeeFireVisionAny cid (_yourID w) w + -> ( (f , g) + , Just $ turnCloseSlow ypos cr + ) -- no longer chase if see you when reloading + -- $ replaceAction [] w + | otherwise -> ( (f , g) , Just cr) + (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) + | otherwise + -> ( ( f , g1) + , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) + , Search (i-1) + ] cr + ) + (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w + -> ( ( f , g1) + , addGoal [[AimAt ypos (2*aimtime)]] cr + ) + | dist cpos p > 10 + -> ( (f,g) , addGoal [[PathTo p]] cr) + | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 + -> ( (f,g) + ,Just $ crTurnTowardSpeed 0.05 p' cr) + | otherwise -> ( (f,g) ,Just cr) + (InitGuard :_) -> ( (f,g) + ,replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr + ) + (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) + | canSeeFireVisionAll cid (_yourID w) w + -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ turnCloseSlow p cr) + | otherwise + -> ( (f,g) , replaceAction [AimAt p (i-1)] $ turnCloseSlow p cr) + +basicShooterAI :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +basicShooterAI w (f,g) cr = + let cpos = _crPos cr + cid = _crID cr + ypos = _crPos $ you w + wp = _crInv cr IM.! _crInvSel cr + (aimtime,g1) = randomR (80,120) g + noAmmo = 0 == _wpLoadedAmmo wp + turnCloseSlow p | errorAngleVV 22 (p -.- cpos) + (unitVectorAtAngle (_crDir cr)) < 0.4 + = crTurnTowardSpeed 0.01 p + | otherwise = crTurnTowardSpeed 0.05 p + replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs) + addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ gs) + replaceAction newActions + = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) + addAction newActions + = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) +-- autoFireTweak p | _wpIsAuto wp = Just +-- | otherwise = replaceGoal [[AimAt p (_wpFireRate wp * 2)]] + in --if _crHP cr <= 0 then killCr w f cr else + case head $ _goals $ _crState cr of + [] | canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | otherwise -> ( ( f , g ) + , replaceGoal [] cr + ) + (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | x == 0 -> ( (f ,g ), replaceAction [] cr ) + | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) + (MoveToFor p x:gls) + | canSeeFire cpos ypos w -> ( (f , g1) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | x == 0 -> ( (f , g) + , replaceAction [] cr + ) + | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr) + | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 + -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) + | otherwise -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 + $ crTurnTowardSpeed 0.05 p cr ) + (PathTo p:_) | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr ) + | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) + | otherwise -> case pointTowardsGoal cpos p w of + Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) + _ -> ( (f , g) , replaceAction [] cr ) + (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) + , replaceGoal [[Reload + ,PathTo p + ,WaitFor 50 + --,Search 1 ,WaitFor 100 + ]] + cr + ) + | canSeeFireVisionAll cid (_yourID w) w + -> ( (tryUseItem cid . f , g) + , replaceGoal [[FireAt ypos]] $ turnCloseSlow p cr + ) + | pathToPointFireable cid p w + -> ( (tryUseItem cid . f , g) + , Just $ turnCloseSlow p cr + ) + | otherwise -> ( (f , g) + , replaceGoal [[PathTo p,WaitFor 50 ]] cr + ) + (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) + | canSeeFireVisionAny cid (_yourID w) w + -> ( (f , g) + , Just $ turnCloseSlow ypos cr + ) -- no longer chase if see you when reloading + -- $ replaceAction [] w + | otherwise -> ( (f , g) , Just cr) + (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) + | otherwise + -> ( ( f , g1) + , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) + , Search (i-1) + ] cr + ) + (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w + -> ( ( f , g1) + , addGoal [[AimAt ypos (2*aimtime)]] cr + ) + | dist cpos p > 10 + -> ( (f,g) , addGoal [[PathTo p]] cr) + | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 + -> ( (f,g) + ,Just $ crTurnTowardSpeed 0.05 p' cr) + | otherwise -> ( (f,g) ,Just cr) + (InitGuard :_) -> ( (f,g) + ,replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr + ) + (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) + | canSeeFireVisionAll cid (_yourID w) w + -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ turnCloseSlow p cr) + | otherwise + -> ( (f,g) , replaceAction [AimAt p (i-1)] $ turnCloseSlow p cr) +sniperAI :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +sniperAI w (f,g) cr = + let cpos = _crPos cr + cid = _crID cr + ypos = _crPos $ you w + wp = _crInv cr IM.! _crInvSel cr + (aimtime,g1) = randomR (80,120) g + noAmmo = 0 == _wpLoadedAmmo wp + turnCloseSlow p | errorAngleVV 22 (p -.- cpos) + (unitVectorAtAngle (_crDir cr)) < 0.4 + = crTurnTowardSpeed 0.01 p + | otherwise = crTurnTowardSpeed 0.05 p + replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs) + addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ gs) + replaceAction newActions + = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) + addAction newActions + = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) +-- autoFireTweak p | _wpIsAuto wp = Just +-- | otherwise = replaceGoal [[AimAt p (_wpFireRate wp * 2)]] + in --if _crHP cr <= 0 then killCr w f cr else + case head $ _goals $ _crState cr of + [] | canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | otherwise -> ( ( f , g ) + , replaceGoal [] cr + ) + (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | x == 0 -> ( (f ,g ), replaceAction [] cr ) + | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) + (MoveToFor p x:gls) + | canSeeFire cpos ypos w -> ( (f , g1) + , replaceGoal [[AimAt ypos aimtime]] cr + ) + | x == 0 -> ( (f , g) + , replaceAction [] cr + ) + | dist p cpos < 1 -> ( (f , g) , replaceAction [] cr) + | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 + -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) + | otherwise -> ( (f , g) + , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 + $ crTurnTowardSpeed 0.05 p cr ) + (PathTo p:_) | dist p cpos < 1 -> ( (f , g) , replaceAction [] cr ) + | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) + | otherwise -> case pointTowardsGoal cpos p w of + Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) + _ -> ( (f , g) , replaceAction [] cr ) + (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) + , replaceGoal [[Reload + ,WaitFor 50 + --,Search 1 ,WaitFor 100 + ]] + cr + ) + | canSeeFireVisionAll cid (_yourID w) w + -> ( (tryUseItem cid . f , g) + , replaceGoal [[FireAt ypos]] $ turnCloseSlow p cr + ) + | pathToPointFireable cid p w + -> ( (tryUseItem cid . f , g) + , Just $ turnCloseSlow p cr + ) + | otherwise -> ( (f , g) + , replaceGoal [[WaitFor 50 ]] cr + ) + (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) + | canSeeFireVisionAny cid (_yourID w) w + -> ( (f , g) + , Just $ turnCloseSlow ypos cr + ) -- no longer chase if see you when reloading + -- $ replaceAction [] w + | otherwise -> ( (f , g) , Just cr) + (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) + | otherwise + -> ( ( f , g1) + , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) + , Search (i-1) + ] cr + ) + (Guard p p':_) | canSeeFireVision cid (_yourID w) w + -> ( ( f , g1) + , addGoal [[AimAt ypos (2*aimtime)]] cr + ) + | dist cpos p > 1 + -> ( (f,g) , addGoal [[PathTo p]] cr) + | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 + -> ( (f,g) + ,Just $ crTurnTowardSpeed 0.05 p' cr) + | otherwise -> ( (f,g) ,Just cr) + (InitGuard :_) -> ( (f,g) + ,replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr + ) + (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) + | canSeeFireVision cid (_yourID w) w + -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ crTurnTowardSpeed 0.2 p cr) + | otherwise + -> ( (f,g) , replaceAction [AimAt p (i-1)] $ turnCloseSlow p cr) +--closeShooterAI :: Int -> World -> World +--closeShooterAI cid w = let cr = _creatures w IM.! cid +-- cpos = _crPos cr +-- ypos = _crPos $ you w +-- wp = _crInv cr IM.! _crInvSel cr +-- noAmmo = 0 == _wpLoadedAmmo wp +-- turnCloseSlow p | errorAngleVV 22 (p -.- cpos) +-- (unitVectorAtAngle (_crDir cr)) < 0.4 +-- = turnTowardSpeed 0.01 p cid +-- | otherwise = turnTowardSpeed 0.05 p cid +-- replaceGoal newGoals = over (creatures . ix cid . crState . goals) +-- (\gs -> newGoals ++ tail gs) +-- addGoal newGoals = over (creatures . ix cid . crState . goals) +-- (\gs -> newGoals ++ gs) +-- replaceAction newActions = over (creatures . ix cid . crState . goals) +-- (\((_:as):ass) -> (newActions ++ as):ass) +-- addAction newActions = over (creatures . ix cid . crState . goals) +-- (\(as:ass) -> (newActions++as):ass) +-- autoFireTweak p | _wpIsAuto wp = id +-- | otherwise = replaceGoal [[AimAt p (_wpFireRate wp * 2)]] +-- in if _crHP cr <= 0 then killCr cid w else +-- case head $ _goals $ _crState cr of +-- [] | canSeeAny cid (_yourID w) w +-- -> replaceGoal [[AimAt ypos 50]] w +-- | otherwise -> replaceGoal [] w +-- (WaitFor x:gls)| canSeeAny cid (_yourID w) w +-- -> replaceGoal [[AimAt ypos 50]] w +-- | x == 0 -> replaceAction [] w +-- | otherwise -> replaceAction [WaitFor (x-1)] w +-- (MoveToFor p x:gls) +-- | canSeeAny cid (_yourID w) w -> replaceGoal [[AimAt ypos 50]] w +-- | x == 0 || not (canSeePoint cid p w) -> replaceAction [] w +-- | dist p cpos < 10 -> replaceAction [] w +-- | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 +-- -> replaceAction [MoveToFor p (x-1)] $ turnTowardSpeed 0.05 p cid w +-- | otherwise -> replaceAction [MoveToFor p (x-1)] +-- $ mvForward speed cid $ turnTowardSpeed 0.05 p cid w +-- (PathTo p:_) | dist p cpos < 10 -> replaceAction [] w +-- | canSeePoint cid p w -> addAction [MoveToFor p 100] w +-- | otherwise -> case pointTowardsGoal cpos p w of +-- Just q -> addAction [MoveToFor q 100] w +-- _ -> replaceAction [] w +-- (MoveFire mp tp:gls) +-- | noAmmo -> replaceGoal [[Reload +-- ,MoveFire mp tp +-- ]] +-- $ tryUseItem cid w +-- | not $ canSeeAll cid (_yourID w) w -> replaceAction [PathTo tp,Search 1] w +-- | dist cpos mp < 10 -> replaceAction [MoveFire ypos ypos] $ turnCloseSlow tp +-- $ tryUseItem cid w +-- | otherwise -> replaceAction [MoveFire mp ypos] +-- $ turnCloseSlow tp $ strafeTo speed mp cid +-- $ tryUseItem cid w +-- (Reload:gls) | _wpReloadState wp == 0 -> replaceAction [] w +-- | canSeeAny cid (_yourID w) w -> turnCloseSlow ypos +-- $ replaceAction [Reload,MoveFire ypos ypos,Search 1] +-- $ replaceAction [] w +-- | otherwise -> w +-- (Guard p p':_)| canSeeAny cid (_yourID w) w +-- -> addGoal [[AimAt ypos 50]] w +-- | dist cpos p > 10 +-- -> addGoal [[PathTo p]] w +-- | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 +-- -> turnTowardSpeed 0.05 p' cid w +-- | otherwise -> w +-- (InitGuard :_) -> replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] w +-- (AimAt p i:_) | i == 0 -> replaceAction [MoveFire p p] w +-- | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 +-- -> replaceAction [AimAt p (i-1)] $ turnTowardSpeed 0.05 p cid w +-- | canSeeAll cid (_yourID w) w +-- -> replaceAction [AimAt ypos (i-1)] $ turnCloseSlow p +-- $ strafeTo speed p cid w +-- | otherwise +-- -> replaceGoal [[AimAt p (i-1),Search 1]] $ turnCloseSlow p +-- $ strafeTo speed p cid w +-- (Search i:gls) | i == 0 -> replaceAction [] w +-- | otherwise -> replaceAction [PathTo (randomPointXStepsFrom 3 cpos w) +-- ] $ over randGen (snd . next) w +-- where speed = 2 + +strafeTo :: Float -> Point2 -> Int -> World -> World +strafeTo speed targPos cid w = over (creatures . ix cid . crPos) (+.+ q) w + where q = (*.*) (speed * equipFactor * wpFactor) + $ safeNormalizeV $ (targPos -.- _crPos cr) + equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! cid + cr = _creatures w IM.! cid + wpFactor = _itAimingSpeed (_crInv cr IM.! _crInvSel cr) + +randomGraphStep :: RandomGen g => Int -> Gr a b -> State g (Maybe Int) +randomGraphStep n g = + do let ns = neighbors g n + i <- state $ randomR (0,length ns - 1) + case ns of [] -> return Nothing + _ -> return $ Just $ ns !! i +randomGraphStepRestricted :: RandomGen g => Int -> [Int] -> Gr a b -> State g (Maybe Int) +randomGraphStepRestricted n notns g = + do let ns = neighbors g n \\ notns + i <- state $ randomR (0,length ns - 1) + case ns of [] -> return Nothing + _ -> return $ Just $ ns !! i + +---- continues a walk from a list of points, without repetitions +---- supposes that the list is non-empty +randomGraphWalk :: RandomGen g => [Int] -> Gr a b -> State g [Int] +randomGraphWalk (n:ns) g = + do next <- randomGraphStepRestricted n ns g + case next of Nothing -> return (n:ns) + Just n' -> randomGraphWalk (n':n:ns) g + +randomPointXStepsFrom :: Int -> Point2 -> World -> Point2 +randomPointXStepsFrom i p w = + let g = _pathGraph w + ns = labNodes g + mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns + in case mp of Nothing -> p + Just (n,_) -> fromJust $ lab g + (last $ take i + $ evalState (randomGraphWalk [n] g) + $ _randGen w) + +randomPointsXStepsFrom :: Int -> Point2 -> World -> [Point2] +randomPointsXStepsFrom i p w = + let g = _pathGraph w + ns = labNodes g + mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns + in case mp of Nothing -> [p] + Just (n,_) -> mapMaybe (lab g ) + (take i + $ evalState (randomGraphWalk [n] g) + $ _randGen w) + + +errorNormalizeVAI :: Point2 -> Point2 +errorNormalizeVAI (0,0) = error $ "problem with function: errorNormalizeVAI in DodgeAIs" +errorNormalizeVAI p = normalizeV p + +splitCritPict' :: Int -> Picture +splitCritPict' i = pictures $ (++) [color (greyN 0.1) $ circleSolid r,color green $ circLine r] $ concatMap (\p -> map (uncurry translate p) pic) $ take (2^(i-1)) rps + where pic = [color green $ circLine 6] + rps = fst $ runState ((sequence . repeat . randInCirc) (r-6)) $ mkStdGen 0 + r = sqrt ((fromIntegral i) * spCrRadFac) + +splitCritPict :: Float -> Picture +splitCritPict x = pictures [color (greyN 0.8) $ circleSolid x, color green $ circLine x] +splitCritCorpse :: Float -> Picture +splitCritCorpse x = color (greyN 0.2) $ circleSolid x +spCrRadFac = 8^2 + +yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +yourControl w (f,g) cr = ( (mouseActionsWorld (_mouseButtons w) . f, g) + , Just $ mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr + ) + where strafeSpeed = 3 * equipFactor * (fromMaybe 1 $ yourItem w ^? itAimingSpeed) + speed = 3 * equipFactor + equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! 0 + +wasdWithAiming :: World -> Float -> Float -> Int -> Creature -> Creature +wasdWithAiming w speed aimSpeed i cr + | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving && isAiming + && diffAngles mouseDir (argV mov) < pi/3 + = over crPos (+.+ (0.2 *.* mov)) +-- $ set ( creatures . ix i . crDir) (argV mov) + $ set crDir mouseDir + $ set (crState . stance . carriage) (Boosting mov) + cr + | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving && isAiming + = set crDir mouseDir + $ set (crState . stance . carriage) Floating + cr + | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving + = over crPos (+.+ (0.2 *.* mov)) +-- $ set ( creatures . ix i . crDir) (argV mov) + -- $ set ( creatures . ix i . crDir) mouseDir + $ over crDir (flip fromMaybe dir) + $ set (crState . stance . carriage) (Boosting mov) + cr + | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isAiming + = set (crState . stance . carriage) Floating + $ set crDir mouseDir + cr + | any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr + = set (crState . stance . carriage) Floating + cr + | isAiming + = -- stopSoundFrom (CrSound i) $ + stepForward' aimSpeed + $ over crPos (+.+ (aimSpeed *.* mov)) + $ set crDir mouseDir + cr + | isMoving + = -- continueOrLoopFrom (CrSound i) twoStepSound $ + stepForward' speed + $ over ( crPos) (+.+ (speed *.* mov)) + $ over ( crDir) (flip fromMaybe dir) + cr + | otherwise + = -- stopSoundFrom (CrSound i) $ + over ( crDir) (flip fromMaybe dir) + cr + where (mov',dir') = wasdComp $ view keys w + (mov,dir) = (rotateV (_cameraRot w) mov',fmap (_cameraRot w +) dir') + isMoving = mov' /= (0,0) + isAiming = (_posture $ _stance $ _crState cr) == Aiming + mouseDir = case w ^? creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment of + Just (Just (ItScope {_scopePos = p})) -> normalizeAngle $ argV + $ p +.+ 2 / _cameraZoom w + *.* rotateV (_cameraRot w) (_mousePos w) + _ -> normalizeAngle $ argV (_mousePos w) + _cameraRot w + +wasdM :: SDL.Keycode -> Point2 +wasdM SDL.KeycodeW = (0,1) +wasdM SDL.KeycodeS = (0,-1) +wasdM SDL.KeycodeD = (1,0) +wasdM SDL.KeycodeA = (-1,0) +wasdM _ = (0,0) + +wasdComp :: S.Set SDL.Keycode -> (Point2,Maybe Float) +wasdComp ks = f $ foldr ( (+.+) . wasdM ) (0,0) ks + where f (0,0) = ((0,0), Nothing) + f p = (errorNormalizeV 46 p, Just $ argV p) + +---------------- +circLine x = line [(0,0),(x,0)] + +sigmoid x = x/sqrt(1+x^2) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs new file mode 100644 index 000000000..bbaf43959 --- /dev/null +++ b/src/Dodge/Base.hs @@ -0,0 +1,740 @@ +--{-# LANGUAGE Strict #-} +{-# LANGUAGE BangPatterns #-} +module Dodge.Base where +-- imports {{{ +import Dodge.Data + +import Geometry +import Picture + +import Control.Lens +import Control.Monad.State + +import Data.List +import Data.Function +import Data.Maybe +import Data.Bifunctor + +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS +import qualified Data.Set as S + +-- }}} +-- +you :: World -> Creature +you w = _creatures w IM.! _yourID w + +aCrPos :: Int -> World -> Point2 +aCrPos i w = _crPos $ _creatures w IM.! i + +yourItem :: World -> Item +yourItem w = _crInv (you w) IM.! _crInvSel (you w) + +yourItemRef w = (creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w))) + +halfWidth,halfHeight :: World -> Float +halfWidth w = _windowX w / 2 +halfHeight w = _windowY w / 2 + +hasLOS :: Point2 -> Point2 -> World -> Bool +{-# INLINE hasLOS #-} +hasLOS p1 p2 w = (not $ collidePointWallsSimple p1 p2 nearbyWalls) + && (not $ collidePointSmoke p1 p2 nearbySmoke) + where nearbyWalls = wallsAlongLine p1 p2 w + nearbySmoke = _smoke w -- smokeAlongLine p1 p2 w + +smokeLOS :: Point2 -> Point2 -> World -> Bool +smokeLOS p1 p2 w = not $ collidePointSmoke p1 p2 nearbySmoke + where nearbySmoke = _smoke w + +hasLOSIndirect :: Point2 -> Point2 -> World -> Bool +hasLOSIndirect p1 p2 w = case collidePointIndirect p1 p2 $ wallsAlongLine p1 p2 w + of Just _ -> False + Nothing -> True && smokeLOS p1 p2 w + +isWalkable :: Point2 -> Point2 -> World -> Bool +isWalkable p1 p2 w = not $ collidePointWalkable p1 p2 nearbyWalls + where nearbyWalls = wallsAlongLine p1 p2 w + +canSee :: Int -> Int -> World -> Bool +canSee i j w = hasLOS p1 p2 w +--canSee i j w = not $ collidePointWallsSimple p1 p2 +-- nearbyWalls + where p1 = _crPos (_creatures w IM.! i) + p2 = _crPos (_creatures w IM.! j) + nearbyWalls = wallsAlongLine p1 p2 w + +canSeePoint :: Int -> Point2 -> World -> Bool +canSeePoint i p w = hasLOS p1 p w +--canSeePoint i p w = case collidePointWalls p1 p nearbyWalls +-- of Just _ -> False +-- Nothing -> True + where nearbyWalls = wallsAlongLine p1 p w + p1 = _crPos (_creatures w IM.! i) + + +pathToPointFireable :: Int -> Point2 -> World -> Bool +pathToPointFireable i p w = not $ collidePointWallsSimple (_crPos (_creatures w IM.! i)) + p + walls + where walls = IM.filter (not . isJust . \wl -> wl ^? blHP) + $ wallsAlongLine p1 p w + p1 = _crPos (_creatures w IM.! i) + +canSeePointAll :: Int -> Point2 -> World -> Bool +canSeePointAll i targPos w = and $ map (flip (canSeePoint i) w . (\p -> (targPos +.+ radius *.* p))) + [(1,0),(0,1),(-1,0),(0,-1)] + where cr = _creatures w IM.! i + cpos = _crPos cr + radius = _crRad cr + +canSeeAny :: Int -> Int -> World -> Bool +canSeeAny fromID toID w = or $ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) + [(1,0),(0,1),(-1,0),(0,-1)] + where cr = _creatures w IM.! toID + cpos = _crPos cr + radius = _crRad cr + +canSeeAll :: Int -> Int -> World -> Bool +canSeeAll fromID toID w = and $ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) + [(1,0),(0,1),(-1,0),(0,-1)] + where cr = _creatures w IM.! toID + cpos = _crPos cr + radius = _crRad cr + +canWalk :: Int -> Int -> World -> Bool +canWalk i j w = not $ collidePointWalkable ipos jpos $ wallsAlongLine ipos jpos w + where ipos = _crPos (_creatures w IM.! i) + jpos = _crPos (_creatures w IM.! j) + +canSeeIndirect :: Int -> Int -> World -> Bool +canSeeIndirect i j w = case collidePointIndirect ipos jpos $ wallsAlongLine ipos jpos w + of Just _ -> False + Nothing -> True && smokeLOS ipos jpos w + where ipos = _crPos (_creatures w IM.! i) + jpos = _crPos (_creatures w IM.! j) + +canSeeFire :: Point2 -> Point2 -> World -> Bool +canSeeFire p p' w = (not $ collidePointFireVision p p' $ wallsAlongLine p p' w) + && smokeLOS p p' w + +canSeeFireVision :: Int -> Int -> World -> Bool +canSeeFireVision i j w = (not $ collidePointFireVision ipos jpos $ wallsAlongLine ipos jpos w) + && smokeLOS ipos jpos w + where ipos = _crPos (_creatures w IM.! i) + jpos = _crPos (_creatures w IM.! j) + +canSeeFireVisionAny :: Int -> Int -> World -> Bool +canSeeFireVisionAny i j w = (not $ and $ fmap ($ (wallsAlongLine (_crPos icr) (_crPos jcr) w) ) + $ zipWith collidePointFireVision ips jps + ) && smokeLOS (_crPos icr) (_crPos jcr) w + where icr = _creatures w IM.! i + jcr = _creatures w IM.! j + ips = map (\p -> (_crPos icr +.+ _crRad icr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)] + jps = map (\p -> (_crPos jcr +.+ _crRad jcr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)] + + +canSeeFireVisionAll :: Int -> Int -> World -> Bool +canSeeFireVisionAll i j w = (not $ or $ fmap ($ (wallsAlongLine (_crPos icr) (_crPos jcr) w) ) + $ zipWith collidePointFireVision ips jps + ) && smokeLOS (_crPos icr) (_crPos jcr) w + where icr = _creatures w IM.! i + jcr = _creatures w IM.! j + ips = map (\p -> (_crPos icr +.+ _crRad icr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)] + jps = map (\p -> (_crPos jcr +.+ _crRad jcr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)] + +-- looks for first collision of a point with walls +-- if found, returns wall +-- I'm sure there is a better way of doing this, one that propagates Nothing in a nice way + +--wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall] +--wallsOnLine p1 p2 ws = hitWalls +-- where hitPoint w = myIntersectSegSeg p1 p2 (_wlLine w !! 0) (_wlLine w !! 1) +-- hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws) + +wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall] +wallsOnLine p1 p2 ws = hitWalls + where hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1) + hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws) + +wallOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Wall +wallOnLine p1 p2 ws + = listToMaybe $ sortBy f hitWalls + where hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1) + --where hitPoint w = myIntersectSegSeg p1 p2 (_wlLine w !! 0) (_wlLine w !! 1) + hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws) + f w1 w2 = compare (magV (p1 -.- fromJust (hitPoint w1))) (magV (p1 -.- fromJust (hitPoint w2))) + +wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> [Wall] +wallsOnCirc p r wls = IM.elems $ IM.filter f wls + where f wl = circOnLine (_wlLine wl !! 0) (_wlLine wl !! 1) p r + +wallsNearPoint :: Point2 -> World -> IM.IntMap Wall +wallsNearPoint p w = IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]] + where (x,y) = zoneOfPoint p + f i m = case IM.lookup i m of Just val -> val + _ -> IM.empty + +-- possible BUG, was associated with thingsHitLongLine +wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall +{-# INLINE wallsAlongLine #-} +--wallsAlongLine a b w = IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfLine a b] +-- where f i m = case IM.lookup i m of Just val -> val +-- _ -> IM.empty +wallsAlongLine a b w = IM.foldrWithKey' g IM.empty kps + where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s)) + kps = zoneOfLine' a b + f i m = case IM.lookup i m of Just val -> val + _ -> IM.empty + +wallsNearZone' :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall +{-# INLINE wallsNearZone' #-} +wallsNearZone' im w = IM.foldrWithKey' g IM.empty im + where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s)) + f i m = case IM.lookup i m of Just val -> val + _ -> IM.empty + + +wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall +wallsAlongCirc p r w = IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfCircle p r] + where f i m = case IM.lookup i m of Just val -> val + _ -> IM.empty + +allWalls :: World -> IM.IntMap Wall +allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _wallsZone w + +creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature +creaturesNearPoint p w = IM.unions [f b $ f a $ _creaturesZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]] + where (x,y) = zoneOfPoint p + f i m = case IM.lookup i m of Just val -> val + _ -> IM.empty + +cloudsNearPoint :: Point2 -> World -> IM.IntMap Cloud +cloudsNearPoint p w = IM.unions [f b $ f a $ _cloudsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]] + where (x,y) = zoneOfPoint p + f i m = case IM.lookup i m of Just val -> val + _ -> IM.empty + +-- possible BUG, occurs when used in thingsHitLongLine +creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature +--creaturesAlongLine a b w = IM.unions [f y $ f x $ _creaturesZone w | (x,y) <- zoneOfLine a b] +-- where f i m = case IM.lookup i m of Just val -> val +-- _ -> IM.empty +creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty kps + where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _creaturesZone w) s)) + kps = zoneOfLine' a b + f i m = case IM.lookup i m of Just val -> val + _ -> IM.empty + +zoneSize :: Float +zoneSize = 50 +--zoneSize = 100 + +floorHun :: Float -> Int +floorHun x = floor $ x / zoneSize +zoneOfPoint :: Point2 -> (Int,Int) +zoneOfPoint (x,y) = (floorHun x, floorHun y) + +zoneNearPoint :: Point2 -> [(Int,Int)] +zoneNearPoint (x',y') = [(a,b) | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]] + where x = floorHun x' + y = floorHun y' + +zoneAroundPoint :: Point2 -> [(Int,Int)] +zoneAroundPoint (x',y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]] + where x = floorHun x' + y = floorHun y' + +zoneAroundPoint' :: Int -> Point2 -> IM.IntMap IS.IntSet +zoneAroundPoint' i (x',y') = IM.fromSet (const ys) xs + where x = floorHun x' + y = floorHun y' + xs = IS.fromAscList [x-i..x+i] + ys = IS.fromAscList [y-i..y+i] + +-- the laser seemed to be occasionally missing creatures, +-- if this reoccurs, maybe change +-- divide line factor from 2 to 1.5 +bres :: Point2 -> Point2 -> [(Int,Int)] +bres a b = bresenham (zoneOfPoint a) (zoneOfPoint b) + +bresx :: Point2 -> Point2 -> [(Int,Int)] +bresx a b = bresenham (x-1,y-1) (x'-1,y'-1) + where (x,y) = zoneOfPoint a + (x',y') = zoneOfPoint b + +zoneOfLine :: Point2 -> Point2 -> [(Int,Int)] +zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f + $ bresenham (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb)) + where f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]] +--zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f +-- $ bresenham (zoneOfPoint (aa-n,ab-n)) (zoneOfPoint (ba-n,bb-n)) +-- where f (x,y) = [(p,r) | p <-[x,x+1] , r<-[y,y+1]] +-- n = zoneSize * 0.5 + +expandLine :: [(Int,Int)] -> IM.IntMap IS.IntSet +{-# INLINE expandLine #-} +expandLine xs = IM.map expandSet + $ IM.unionsWith IS.union [im, IM.mapKeysMonotonic (+1) im, IM.mapKeysMonotonic (+2) im] + where im = IM.fromListWith IS.union $ map (\(a,b)->(a,IS.singleton b)) xs + expandSet s = IS.insert (mk+2) $ IS.insert (mk+1) s + --expandSet s = s + where mk = IS.findMax s + +zoneOfLine' :: Point2 -> Point2 -> IM.IntMap IS.IntSet +{-# INLINE zoneOfLine' #-} +zoneOfLine' a b = expandLine $ bresenham (x-1,y-1) (x'-1,y'-1) + where (x,y) = zoneOfPoint a + (x',y') = zoneOfPoint b + +--zoneOfLine a b = concatMap zoneNearPoint $ divideLine (2 * zoneSize) a b +--zoneOfLine a b = concatMap zoneNearPoint $ divideLine zoneSize a b + +zoneOfCircle :: Point2 -> Float -> [(Int,Int)] +zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r + +-- looking at this again, I am not convinced it deals correctly with the +-- rotation of the world +zoneOfScreen :: World -> [(Int,Int)] +zoneOfScreen w = [(a,b) | a <- [x - n .. x + n] + , b <- [y - n .. y + n] + ] + where (x,y) = zoneOfPoint $ _cameraPos w + n = ceiling $ wh / (_cameraZoom w * zoneSize) + wh = max (_windowX w) (_windowY w) + +zoneOfDoubleScreen :: World -> [(Int,Int)] +zoneOfDoubleScreen w = [(a,b) | a <- [x - n .. x + n] + , b <- [y - n .. y + n] + ] + where (x,y) = zoneOfPoint $ _cameraPos w + n = (ceiling $ wh / (_cameraZoom w * zoneSize)) * 2 + wh = max (_windowX w) (_windowY w) + +zoneOfSight :: World -> [(Int,Int)] +zoneOfSight w = [(a,b) | a <- [minimum xs .. maximum xs] + , b <- [minimum ys .. maximum ys] + ] + where (xs,ys) = unzip $ map zoneOfPoint $ screenPolygon w ++ [_cameraCenter w] + +screenPolygon :: World -> [Point2] +screenPolygon w = [tr,tl,bl,br] + where scRot = rotateV (_cameraRot w) + scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p + scTran p = p +.+ _cameraPos w + tr = scTran $ scRot $ scZoom ( halfWidth w, halfHeight w) + tl = scTran $ scRot $ scZoom (-halfWidth w, halfHeight w) + br = scTran $ scRot $ scZoom ( halfWidth w,-halfHeight w) + bl = scTran $ scRot $ scZoom (-halfWidth w,-halfHeight w) + +wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall +wallsNearZones is w = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is] + where f i m = case IM.lookup i m of Just val -> val + _ -> IM.empty + +ixZone :: IM.IntMap (IM.IntMap a) -> Point2 -> a +ixZone z (x,y) = z IM.! floorHun x IM.! floorHun y + +ixNZ :: IM.IntMap (IM.IntMap a) -> Point2 -> [a] +ixNZ z p = lookLookups (zoneNearPoint p) z + +lookLookup :: Int -> Int -> (IM.IntMap (IM.IntMap a)) -> Maybe a +lookLookup i j z = case IM.lookup i z of + Just z' -> IM.lookup j z' + Nothing -> Nothing + +lookLookups :: [(Int,Int)] -> (IM.IntMap (IM.IntMap a)) -> [a] +lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs + +-- looks for first collision of a point with walls +-- if found, gives point and reflection velocity +collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2) +collidePointWalls p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe + (( \(x:y:_) -> fmap (flip (,) + (reflectIn (x -.- y) (p2 -.- p1)) + . (+.+ errorNormalizeV 39 (vNormal (x -.- y))) + ) (intersectSegSeg' p1 p2 x y) + ) . _wlLine + ) ws + where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b)) +-- looks for if a point collides with walls +collidePointWallsSimple :: Point2 -> Point2 -> IM.IntMap Wall -> Bool +collidePointWallsSimple p1 p2 = any $ isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) + . _wlLine + +collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool +collidePointWalkable p1 p2 ws = any (isJust + . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) + . _wlLine + ) unwalkableWalls + where unwalkableWalls = IM.filter notDoor ws + notDoor (AutoDoor {}) = False + notDoor _ = True + +furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2 +furthestPointWalkable p1 p2 ws = head $ (sortBy (compare `on` dist p1) $ IM.elems + $ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) + . _wlLine + ) ws + ) ++ [p2] + +collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2 +collidePointIndirect p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems + $ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) + . _wlLine + ) notWindows + where notWindows = IM.filter (not . _wlIsSeeThrough) ws + +collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2 +collidePointFire p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems + $ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) + . _wlLine + ) notWindows + where notWindows = IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP)) + ) ws + +collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool +collidePointFireVision p1 p2 ws = any ( isJust + . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) + . _wlLine + ) + $ IM.filter notBlockWindow ws + where notBlockWindow wl = case wl ^? blHP of + Just _ -> not $ _wlIsSeeThrough wl + Nothing -> True + +collidePointSmoke :: Point2 -> Point2 -> [Smoke] -> Bool +collidePointSmoke a b = any $ isJust . uncurry (intersectSegSeg' a b) . smokePerpLine a b + +smokePerpLine :: Point2 -> Point2 -> Smoke -> (Point2,Point2) +smokePerpLine a b sm = (p +.+ orth, p -.- orth) + where + p = _smPos sm + orth = _smRad sm *.* safeNormalizeV (vNormal (a -.- b)) + +-- shit this is ugly +lineOfThickness :: Float -> [Point2] -> Picture +lineOfThickness t = pictures . f + where f (x:y:ys) + | x == y = f (x:ys) + | otherwise + = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys) + f _ = [] + n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b)) + +wedgeOfThickness :: Float -> Point2 -> Point2 -> Picture +wedgeOfThickness t x y + | x == y = blank + | otherwise = pictures [uncurry translate x $ circleSolid (0.5*t) + ,polygon [x +.+ n x y, x -.- n x y, y] + ] + where n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b)) + +insertInZoneWith :: Int -> Int -> (a -> a -> a) -> a -> IM.IntMap (IM.IntMap a) + -> IM.IntMap (IM.IntMap a) +insertInZoneWith x y fun obj = IM.insertWith f x $ IM.singleton y obj + where-- f :: IM.IntMap a -> IM.IntMap a -> IM.IntMap a + f _ = IM.insertWith fun y obj + +insertIMInZone :: Int -> Int -> Int -> a -> IM.IntMap (IM.IntMap (IM.IntMap a)) + -> IM.IntMap (IM.IntMap (IM.IntMap a)) +insertIMInZone x y obid obj = IM.insertWith f x $ IM.singleton y $ IM.singleton obid obj + where f _ = IM.insertWith g y $ IM.singleton obid obj + g _ = IM.insert obid obj + +adjustIMZone :: (a -> a) -> Int -> Int -> Int -> IM.IntMap (IM.IntMap (IM.IntMap a)) + -> IM.IntMap (IM.IntMap (IM.IntMap a)) +adjustIMZone f x y n m = IM.adjust f' x m + where f' = IM.adjust f'' y + f'' = IM.adjust f n + + +newKey :: IM.IntMap a -> Int +newKey m = case IM.lookupMax m of + Just (n,_) -> n+1 + Nothing -> 0 + +newParticleKey :: World -> Int +newParticleKey w = case IM.lookupMax (_particles w) of + Just (n,_) -> n+1 + Nothing -> 0 +newCrKey :: World -> Int +newCrKey w = case IM.lookupMax (_creatures w) of + Just (n,_) -> n+1 + Nothing -> 0 + +insertNewKey :: a -> IM.IntMap a -> IM.IntMap a +insertNewKey x m = case IM.lookupMax m of + Nothing -> IM.singleton 0 x + Just (k,_) -> IM.insert (k+1) x m + +reflectPointCreature :: Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int) +reflectPointCreature p1 p2 cr = + case collidePointCirc p1 p2 (_crRad cr) (_crPos cr) of + Nothing -> Nothing + Just p3 -> Just ( p1 + , errorNormalizeV 35 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr) + +.+ (_crPos cr -.- _crOldPos cr) + --, errorNormalizeV 36 $ + -- ssaTriPoint p1 (_crPos cr) p2 (_crRad cr) + -- -.- _crOldPos cr + , _crID cr) + +reflectPointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int) +reflectPointCreatures p1 p2 cs = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe + (reflectPointCreature p1 p2) cs + where f (a,_,_) (b,_,_) = compare (magV (a -.- p1)) (magV (b -.- p1)) + + +reflectCircCreature :: Float -> Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int) +reflectCircCreature rad p1 p2 cr = + case collidePointCirc p1 p2 (rad + _crRad cr) (_crPos cr) of + Nothing -> Nothing + Just p3 -> Just ( p1 + , errorNormalizeV 37 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr) + +.+ (_crPos cr -.- _crOldPos cr) + --, errorNormalizeV 38 $ + -- ssaTriPoint p1 (_crPos cr) p2 (_crRad cr) + -- -.- _crOldPos cr + , _crID cr) + +reflectCircCreatures :: Float -> Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int) +reflectCircCreatures rad p1 p2 cs = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe + (reflectCircCreature rad p1 p2) cs + where f (a,_,_) (b,_,_) = compare (magV (a -.- p1)) (magV (b -.- p1)) + +-- collides a point with forcefields +-- if found, returns point of collision, deflection if required, and the id +collidePointFFs = undefined +collidePointFF = undefined +-- +--collidePointFFs :: Point2 -> Point2 -> StdGen -> IM.IntMap ForceField +-- -> Maybe (Point2,(Maybe (Point2,StdGen),Int)) +--collidePointFFs p1 p2 g fs = listToMaybe $ sortBy f $ IM.elems +-- $ IM.mapMaybe (collidePointFF p1 p2 g) fs +-- where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b)) +-- +--collidePointFF :: Point2 -> Point2 -> StdGen -> ForceField +-- -> Maybe (Point2,(Maybe (Point2,StdGen),Int)) +--collidePointFF p1 p2 g ff = fmap f ip +-- where (p3:p4:_) = _ffLine ff +-- ip = intersectSegSeg' p1 p2 p3 p4 +-- ref = (_ffDeflect ff) <*> Just g <*> Just (p2 -.- p1) <*> Just ff +-- f p = (p, (ref, _ffID ff)) +-- + +-- looks for first collision of a point with walls +-- if found, gives point and reflection velocity, reflection damped in normal +collidePointWalls' :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2) +collidePointWalls' p1 p2 ws + = listToMaybe $ sortBy f $ IM.elems + $ IM.mapMaybe + (( \(x:y:_) -> fmap (flip (,) (reflectInParam 0.5 (x -.- y) (p2 -.- p1)) + . (+.+ errorNormalizeV 40 (vNormal (x -.- y))) + ) + (intersectSegSeg' p1 p2 x y) + ) . _wlLine + ) ws + where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b)) + +-- looks for first collision of a circle with walls +-- if found, gives point and reflection velocity, reflection damped in normal +collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2) +collideCircWalls' p1 p2 rad ws + = listToMaybe $ sortBy f $ IM.elems + $ IM.mapMaybe + (( \(x:y:_) -> fmap (flip (,) (reflectInParam 0.5 (x -.- y) (p2 -.- p1)) + . (+.+ errorNormalizeV 40 (vNormal (x -.- y))) + ) + (intersectSegSeg' p1 p2 x y) + ) . shiftByRad . _wlLine + ) ws + where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b)) + shiftByRad (a:b:_) = map ((+.+) (rad *.* normalizeV (vNormal (a -.- b)))) + [a +.+ rad *.* (normalizeV (a -.-b)) + ,b +.+ rad *.* (normalizeV (b -.-a)) + ] +-- this shifts the wall out, and for outer corners extends the wall +-- not sure what this does for inner corners, hopefully won't cause a problem +-- the alternative would be to separately bounce off corner points... +-- unfortunately, doesn't allow for collisions when the circle spawns on the +-- wall + +-- looks for first collision of a point with walls +-- if found, gives point and normal of wall +collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2) +collidePointWallsNorm p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe + (( \(x:y:_) -> fmap (flip (,) ( vNormal $ x -.- y )) + (intersectSegSeg' p1 p2 x y) + ) . _wlLine + ) ws + where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b)) + +-- looks for first collision of a point with walls +-- if found, gives point and colour of wall +collidePointWallsCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Color) +collidePointWallsCol p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe + ( (\(m, c) -> fmap (flip (,) c) m) + . (\w -> (intersectSegSeg' p1 p2 + (_wlLine w !! 0) (_wlLine w !! 1), _wlColor w)) + ) ws + where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b)) +-- looks for first collision of a point with walls +-- if found, gives point, and normal and colour of wall +collidePointWallsNormCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2,Color) +collidePointWallsNormCol p1 p2 ws + = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe m ws + where f (a,_,_) (b,_,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b)) + ls w = let (x:y:_) = _wlLine w + in (intersectSegSeg' p1 p2 x y, vNormal (x -.- y), _wlColor w) + m w = let (a1,a2,a3) = ls w + in fmap (\a4 -> (a4,a2,a3)) a1 + +--returns the first creature, if any, that a point intersects with +collidePointCreatures :: Point2 -> Point2 -> World -> Maybe Int +collidePointCreatures p1 p2 w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $ + IM.mapMaybe (\x -> + collidePointCirc' p1 p2 (_crRad x) (_crPos x) + ) + (_creatures w) + where csnd (_,a) (_,b) = compare a b +--as for collidePointCreatures, only increases the radius of creatures by a +--fixed amount, thus collides a moving circle with creaures +collideCircCreatures :: Point2 -> Point2 -> Float -> World -> Maybe Int +collideCircCreatures p1 p2 rad w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $ + IM.mapMaybe (\x -> + collidePointCirc' p1 p2 (rad + _crRad x) (_crPos x) + ) + (_creatures w) + where csnd (_,a) (_,b) = compare a b + + +--returns the first creature, if any, that a point intersects with, gives point +--in creature on line +collidePointCrsPoint :: Point2 -> Point2 -> World -> Maybe (Point2,Int) +collidePointCrsPoint p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $ + IM.mapMaybe (\x -> + collidePointCirc'' p1 p2 (_crRad x) (_crPos x) + ) + (_creatures w) + where csndsnd (_,(_,a)) (_,(_,b)) = compare a b + f (cID,(p,_)) = (p,cID) +collideCircCrsPoint :: Point2 -> Point2 -> Float -> World -> Maybe (Point2,Int) +collideCircCrsPoint p1 p2 rad w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $ + IM.mapMaybe (\x -> + collidePointCirc'' p1 p2 (rad + _crRad x) (_crPos x) + ) + (_creatures w) + where csndsnd (_,(_,a)) (_,(_,b)) = compare a b + f (cID,(p,_)) = (p,cID) + + +-- makes a creatures not hittable +collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int) +collidePointCrsWithoutPoint cid p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $ + IM.mapMaybe (\x -> + collidePointCirc'' p1 p2 (_crRad x) (_crPos x) + ) + (IM.delete cid $ _creatures w) + where csndsnd (_,(_,a)) (_,(_,b)) = compare a b + f (cID,(p,_)) = (p,cID) + +circOnSomeWall :: Point2 -> Float -> World -> Bool +circOnSomeWall p rad w = any (\(x:y:_) -> circOnLine x y p rad) + $ fmap _wlLine $ IM.elems $ wallsNearPoint p w + +crsNearLine :: Float -> [Point2] -> World -> Bool +crsNearLine d (p1:p2:_) w = any (\c -> circOnLine p1 p2 (_crPos c) (d + _crRad c)) + $ IM.filter (\cr -> _crMass cr > 4) $ _creatures w + +crsNearPoint :: Float -> Point2 -> World -> Bool +crsNearPoint d p w = any (\c -> dist (_crPos c) p < (d + _crRad c)) (_creatures w) + +crsOnLine :: Point2 -> Point2 -> World -> [Creature] +crsOnLine p1 p2 w = IM.elems + $ IM.filter (\cr -> circOnLine p1 p2 (_crPos cr) (_crRad cr)) + $ _creatures w + +crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature] +crsOnThickLine thickness p1 p2 w = IM.elems + $ IM.filter (\cr -> circOnLine p1 p2 (_crPos cr) (_crRad cr + thickness)) + $ _creatures w + +nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature +nearestCrInRad p r w = let crs = IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w + sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs + in listToMaybe sortedCrs + +nearestCrInTri :: Point2 -> Float -> Float -> World -> Maybe Creature +nearestCrInTri p dir x w + = let crs = IM.filter (\cr -> errorPointInPolygon 1 (_crPos cr) tri) $ _creatures w + sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs + in listToMaybe sortedCrs + where tri = [p + ,p +.+ rotateV (dir-pi/4) (x,0) + ,p +.+ rotateV (dir+pi/4) (x,0) + ] + +nearestCrInFront :: Point2 -> Float -> Float -> World -> Maybe Creature +nearestCrInFront p dir x w + = let crs = IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w + sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs + in listToMaybe sortedCrs + where rec = [p + ,pR + ,pR1 + ,pL1 + ,pL + ] + pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0) + pL = p +.+ rotateV (dir + pi*(3/8)) (x/2,0) + pR1 = pR +.+ rotateV dir (x/2,0) + pL1 = pL +.+ rotateV dir (x/2,0) + +crInPolygon :: Creature -> [Point2] -> Bool +crInPolygon cr xs = errorPointInPolygon 3 (_crPos cr) xs + +onLayer :: Layer -> Picture -> Picture +onLayer l = setDepth (fromIntegral (levLayer l) / 100) + +--onLayer :: Layer -> Picture -> [(Picture, [Int])] +--onLayer l p = [(p, [levLayer l])] + +onLayerL :: [Int] -> Picture -> Picture +onLayerL is = setDepth (sum $ zipWith (/) (map fromIntegral is) $ map (\x->100**x) [1..]) + +levLayer :: Layer -> Int +levLayer BgLayer = 20 +levLayer PressPlateLayer = 45 +levLayer CorpseLayer = 50 +levLayer FlItLayer = 55 +levLayer CrLayer = 60 +levLayer WlLayer = 65 +levLayer GloomLayer = 67 +levLayer UPtLayer = 70 +levLayer PtLayer = 72 +levLayer HPtLayer = 73 +levLayer ShadowLayer = 75 +levLayer LabelLayer = 80 +levLayer InvLayer = 85 +levLayer MenuLayer = 90 + +mouseWorldPos :: World -> Point2 +mouseWorldPos w = _cameraPos w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w) + +logistic :: Float -> Float -> Float -> (Float -> Float) +logistic x0 l k x = l / (1 + exp (k*(x0 - x))) + +wallLOS :: [Point2] -> Point2 -> Point2 -> Bool +{-# INLINE wallLOS #-} +wallLOS !(x:y:_) !c !p = isRHS c x y || isLHS p x' y' || isLHS c p x || isRHS c p y + where n = 10 *.* (normV . vNormal $ y -.- x) + x' = x +.+ n + y' = y +.+ n + +wallsLOS :: Foldable t => t [Point2] -> Point2 -> Point2 -> Bool +{-# INLINE wallsLOS #-} +wallsLOS !ls !c !p = all (\l -> wallLOS l c p) ls + +translateDrawing = translate +rotateDrawing = rotate diff --git a/src/Dodge/Block.hs b/src/Dodge/Block.hs new file mode 100644 index 000000000..dcb67b948 --- /dev/null +++ b/src/Dodge/Block.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE BangPatterns #-} +module Dodge.Block where +import Dodge.Data +import Dodge.Base +import Dodge.SoundLogic + +import Geometry +import Picture.Data + +import Control.Lens + +import Data.List + +import Data.Function +import qualified Data.IntMap.Strict as IM +import System.Random +import Control.Monad.State + +updateBlocks :: World -> World +updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) deadPanes + $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls) + degradeBlocks +-- w + where degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks + removeFromZone :: Wall -> World -> World + removeFromZone bl = over (wallsZone . ix x . ix y) (IM.delete (_wlID bl)) + where (x,y) = zoneOfPoint $ pHalf (_wlLine bl !! 0) (_wlLine bl !! 1) + deadPanes = filter blockIsDead (IM.elems $ _walls w) + deadBlocks = nubBy ((==) `on` _blIDs) deadPanes + blockIsDead wl = case wl ^? blHP of Just x -> x <= 0 + Nothing -> False + + +killBlock :: Wall -> World -> World +killBlock bl w = f bl . + flip (foldr unshadow) +-- flip (foldr (\i -> set (walls . ix i . blVisible) (True))) + (_blShadows bl) + $ w + where + f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl + f bl = hitSound' bl + hitSound bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+8) 25 0 + | otherwise = soundMultiFrom sos soundid 25 0 + hitSound' bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+4) 25 0 + | otherwise = soundMultiFrom sos soundid 25 0 + sos = [BlockDegradeSound 0,BlockDegradeSound 1] + (soundid,_) = randomR (29,32) $ _randGen w + unshadow :: Int -> World -> World + unshadow bid w = case w ^? walls . ix bid of + Just b -> let (x,y) = zoneOfPoint $ pHalf (_wlLine b !! 0) (_wlLine b !! 1) + in w & wallsZone . ix x . ix y . ix bid . blVisible %~ \_ -> True + Nothing -> w + +degradeBlock :: Wall -> World -> World +degradeBlock bl w = let blid = _wlID bl + bls = map (\i -> _walls w IM.! i) (_blIDs $ _walls w IM.! blid) + ps = reverse $ orderPolygon $ nub $ concatMap _wlLine bls + (newPs,g) = runState (shrinkPolygon 0.5 ps) $ _randGen w + (x:xs) = _blDegrades bl + in addBlock newPs (x + _blHP bl) (_wlColor bl) (_wlIsSeeThrough bl) xs $ set randGen g w + +pushPointTowardsBy :: RandomGen g => Float -> Point2 -> [Point2] -> State g Point2 +pushPointTowardsBy x p ps = do + xs <- sequence $ take (length ps) $ repeat $ state $ randomR (0, x / (fromIntegral $ length ps)) + let toAdd p' y = y *.* (p' -.- p) + return $ p +.+ foldr1 (+.+) (zipWith toAdd ps xs) + +shrinkPolygon :: RandomGen g => Float -> [Point2] -> State g [Point2] +shrinkPolygon x ps = sequence $ map (flip (pushPointTowardsBy x) ps) ps + + +addBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World +addBlock (p:ps) hp col isSeeThrough degradability w + | hp <= 0 && degradability == [] = w + | hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w + | otherwise = over wallsZone (flip (IM.foldr wallInZone) blocks) + $ over walls (IM.union blocks) w +--addBlock (p:p':ps) w = over walls (IM.insert i b) w + where + lines = zip (p:ps) (ps ++ [p]) + i = newKey $ _walls w + is = [i.. i + length lines-1] + blocks = IM.fromList $ zip is + $ zipWith (\j (a,b) -> Block { _wlLine = [a,b] + , _wlID = j + -- , _wlColor = greyN 0.5 + , _wlColor = col + , _wlDraw = Nothing + , _wlSeen = False + , _blIDs = is + , _blHP = hp + , _wlIsSeeThrough = isSeeThrough + , _blVisible = True + , _blShadows = [] + , _blDegrades = degradability + } + ) is lines + wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize + = insertIMInZone x y wlid wl + | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips + where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1)) + wlid = _wlID wl + ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1) + diff --git a/src/Dodge/Camera.hs b/src/Dodge/Camera.hs new file mode 100644 index 000000000..033c056e1 --- /dev/null +++ b/src/Dodge/Camera.hs @@ -0,0 +1,163 @@ +module Dodge.Camera where + +import Dodge.Data +import Dodge.Base + +import Geometry + +import Control.Lens +import Control.Monad + +import Data.Maybe +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM + +import qualified SDL as SDL + +updateCamera :: World -> World +updateCamera = rotCam . moveCamera . updateAimTime . updateScopeZoom + +updateAimTime :: World -> World +updateAimTime w + | SDL.ButtonRight `S.member` _mouseButtons w + = w & cameraAimTime %~ \t -> min (t+1) 10 + | otherwise = w & cameraAimTime %~ \t -> max (t-1) 0 + +moveCamera :: World -> World +moveCamera w = w & cameraPos .~ idealPos + & cameraCenter .~ sightFrom + where aimRangeFactor | _cameraZoom w == 0 = 0 + | otherwise = (fromMaybe 0 $ yourItem w ^? itAimingRange) / _cameraZoom w + aimTimeFactor = fromIntegral (w ^. cameraAimTime) / 10 + aimingMult | SDL.ButtonRight `S.member` _mouseButtons w = 1 + | otherwise = 0 + ypos = _crPos $ you w + idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w) + currentOffset = currentPos -.- camCenter + idealPos = camCenter +.+ rotateV (_cameraRot w) + -- (aimRangeFactor * aimTimeFactor *.* _mousePos w) + (aimRangeFactor * aimingMult *.* _mousePos w) + currentPos = _cameraPos w + camCenter = ypos +.+ scope + isCam :: Bool + isCam = fromMaybe False $ yourItem w ^? itAttachment . _Just . scopeIsCamera + scope = fromMaybe (0,0) $ yourItem w ^? itAttachment . _Just . scopePos + sightFrom | isCam = camCenter + | otherwise = ypos + + + + +updateScopeZoom :: World -> World +updateScopeZoom w + | SDL.ButtonRight `S.member` _mouseButtons w = case w ^? scppoint of + Just x + | x > 9 -> zoomInLongGun $ zoomInLongGun + $ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment . _Just . scopeZoomChange -~ 2 + | x > 0 -> zoomInLongGun + $ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment . _Just . scopeZoomChange -~ 1 + | x < -9 -> zoomOutLongGun $ zoomOutLongGun + $ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment . _Just . scopeZoomChange +~ 2 + | x < 0 -> zoomOutLongGun $ zoomOutLongGun + $ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment . _Just . scopeZoomChange +~ 1 + | otherwise -> w + _ -> w + | otherwise = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment . _Just %~ updateScope + where scppoint = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment . _Just . scopeZoomChange + updateScope (ItScope _ _ _ bl) = ItScope (0,0) 0 1 bl + updateScope otherAtt = otherAtt + +zoomSpeed = 39/40 + +zoomInLongGun :: World -> World +zoomInLongGun w | currentZoom < 8 = over (wpPointer . itAttachment . _Just . scopePos) + (\p -> p +.+ (4-(4*zoomSpeed)) / currentZoom *.* mousep) + $ over (wpPointer . itAttachment . _Just . scopeZoom) (\z -> z / zoomSpeed) + w + | otherwise = w + where wpPointer = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + wp = _crInv (_creatures w IM.! 0) IM.! (_crInvSel (_creatures w IM.! 0)) + Just currentZoom = wp ^? itAttachment . _Just . scopeZoom + mousep = rotateV (_cameraRot w) $ _mousePos w + +zoomOutLongGun :: World -> World +zoomOutLongGun w | currentZoom > 0.5 = over (wpPointer . itAttachment . _Just . scopePos) +-- (\p -> p -.- 2/(2 * currentZoom) *.* _mousePos w) +-- (\p -> p -.- 2*zoomSpeed/currentZoom *.* p) + (\p -> p) + $ over (wpPointer . itAttachment . _Just . scopeZoom) (\z -> z * zoomSpeed) + w + | otherwise = w + where wpPointer = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + wp = _crInv (_creatures w IM.! 0) IM.! (_crInvSel (_creatures w IM.! 0)) + Just currentZoom = wp ^? itAttachment . _Just . scopeZoom + currentCursorDisplacement = fromJust $ _itAttachment wp + +rotCam = rotateCameraL . rotateCameraR . zoomCamIn . zoomCamOut . zoomCam + +rotateCameraL :: World -> World +rotateCameraL w | SDL.KeycodeQ `S.member` _keys w + = w & cameraRot +~ 0.015 + & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment . _Just . scopePos %~ rotateV 0.015 + | otherwise = w +rotateCameraR :: World -> World +rotateCameraR w | SDL.KeycodeE `S.member` _keys w + = w & cameraRot -~ 0.015 + & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment . _Just . scopePos %~ rotateV (-0.015) + | otherwise = w +zoomCamIn :: World -> World +zoomCamIn w | SDL.KeycodeJ `S.member` _keys w + = w {_cameraZoom = _cameraZoom w + 0.01} + | otherwise = w +zoomCamOut :: World -> World +zoomCamOut w | SDL.KeycodeK `S.member` _keys w + = w {_cameraZoom = max (_cameraZoom w - 0.01) 0.01} + | otherwise = w + +-- the 395 here limits the max zoom out, is 25 less than the current screen +-- size, thus matches up with it +zoomCam :: World -> World +--zoomCam w = w +zoomCam w = over cameraZoom changeZoom w + where maxViewDistance = 800 + camPos = _cameraCenter w + camRot = _cameraRot w + wallZoom = min (halfWidth w / (horizontalMax+10) ) + (halfHeight w / (verticalMax+10) ) + idealZoom | SDL.ButtonRight `S.member` _mouseButtons w + = scZoom * + ( + min (fromMaybe 20 $ yourItem w ^? itZoom . itAimZoomMax) + $ max (fromMaybe 0.2 $ yourItem w ^? itZoom . itAimZoomMin) + (wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itAimZoomFac)) + ) + | otherwise + = min (fromMaybe 20 $ yourItem w ^? itZoom . itZoomMax) + $ max (fromMaybe 0.2 (yourItem w ^? itZoom . itZoomMin)) + (wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itZoomFac)) + changeZoom curZoom | curZoom > idealZoom + 0.01 = 0.05 * (19*curZoom + idealZoom) + | curZoom < idealZoom - 0.01 = 0.05 * (19*curZoom + idealZoom) + | otherwise = idealZoom +-- zs = take 20 [-maxViewDistance,0 - 0.9*maxViewDistance..] + zs = take 9 [-maxViewDistance,0 - 0.8*maxViewDistance..] + rRays = rotF [( maxViewDistance,y) | y <- zs] + lRays = rotF [(-maxViewDistance,y) | y <- zs] + tRays = rotF [(y, maxViewDistance) | y <- zs] + bRays = rotF [(y,-maxViewDistance) | y <- zs] + rotF = map (h . (+.+) camPos . rotateV (_cameraRot w)) + h p = fromMaybe p $ collidePointIndirect camPos p $ wallsAlongLine camPos p w + h' x p = dotV (rotateV camRot x) (p -.- camPos) + horizontalMax = maximum $ map (h' (1,0)) rRays ++ map (h' (-1,0)) lRays + verticalMax = maximum $ map (h' (0,1)) tRays ++ map (h' (0,-1)) bRays + scZoom = fromMaybe 1 $ yourItem w ^? itAttachment . _Just . scopeZoom + +dirRays :: Float -> [Point2] +dirRays dir = take 11 $ iterate (rotateV (0.5 * pi / 10)) $ rotateV (dir-pi*0.25) (600,0) diff --git a/src/Dodge/CreatureActions.hs b/src/Dodge/CreatureActions.hs new file mode 100644 index 000000000..78de6cd5d --- /dev/null +++ b/src/Dodge/CreatureActions.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE BangPatterns #-} +module Dodge.CreatureActions where +-- imports {{{ +import Dodge.Data +import Dodge.Base +import Dodge.SoundLogic +import Dodge.WorldActions + +import Geometry +import Picture + +import Control.Lens +import Control.Monad +import Control.Applicative + +import Data.Maybe +import Data.List + +import System.Random + +import qualified Data.IntMap.Strict as IM +import qualified Data.Map as M +-- }}} + +moveForwardSpeed :: Float -> Int -> World -> World +moveForwardSpeed x n w = over (creatures . ix n . crPos) (+.+ p) w + where p = (*.*) x $ unitVectorAtAngle $ _crDir $ _creatures w IM.! n + +mvForward :: Float -> Int -> World -> World +mvForward speed cid w = stepForward cid speed $ over (creatures . ix cid . crPos) (+.+ p) w + where p = (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir $ _creatures w IM.! cid + equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! cid + +crStrafeLeft :: Float -> Creature -> Creature +crStrafeLeft speed cr = stepForward' s2 $ over crPos (+.+ p) cr + where p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr + pi/2) + equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr + s2 = (speed * equipFactor) +crStrafeRight :: Float -> Creature -> Creature +crStrafeRight speed cr = stepForward' s2 $ over crPos (+.+ p) cr + where p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr - pi/2) + equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr + s2 = (speed * equipFactor) + +crMvForward :: Float -> Creature -> Creature +crMvForward speed cr = over crPos (+.+ p) cr + where p = (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir cr + equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr + +crMvBy :: Point2 -> Creature -> Creature +crMvBy p' cr = stepForward' (magV p) $ over crPos (+.+ p) cr + where p = (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p' + equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr + aimingFactor | (_posture $ _stance $ _crState cr) == Aiming + = fromMaybe 1 $ it ^? itAimingSpeed + | otherwise = 1 + it = _crInv cr IM.! _crInvSel cr + +stepForward :: Int -> Float -> World -> World +stepForward cid speed = over (creatures . ix cid . crState . stance . carriage) f + where f (w@Walking {}) = w {_stepToAdd = ceiling speed} + f s = s + +stepForward' :: Float -> Creature -> Creature +stepForward' speed cr = over (crState . stance . carriage) f cr + where f (w@Walking {}) = w {_stepToAdd = ceiling speed} + f s = s + +equipSpeed NoItem = 1 +equipSpeed it | _itIdentity it == FrontArmour = 0.75 + | _itIdentity it == FlameShield = 0.75 + | otherwise = 1 + +turnTo :: Point2 -> Int -> World -> World +turnTo p n w = set (creatures . ix n . crDir) dirToTarget w + where cr = _creatures w IM.! n + dirToTarget = argV (p -.- _crPos cr) + +turnToward :: Point2 -> Int -> World -> World +turnToward p n w | isLeftOfA dirToTarget (_crDir cr) + = f $ over (creatures . ix n . crDir) + (normalizeAngle . (+ (0.03 + r*m))) w + | otherwise = f $ over (creatures . ix n . crDir) + (\x->normalizeAngle (x - (0.03 + r*m))) w + where cr = _creatures w IM.! n + dirToTarget = argV (p -.- _crPos cr) + (r,g) = randomR (-0.1,0.1) (_randGen w) + m = diffAngles dirToTarget (_crDir cr) + f = set randGen g + +turnTowardAngle :: Float -> Int -> World -> World +turnTowardAngle a n w + | isLeftOfA a (_crDir cr) = f $ over (creatures . ix n . crDir) + (normalizeAngle . (+ (0.03 + r*m))) w + | otherwise = f $ over (creatures . ix n . crDir) + (\x->normalizeAngle (x - (0.03 + r*m))) w + where cr = _creatures w IM.! n + (r,g) = randomR (-0.1,0.1) (_randGen w) + m = diffAngles a (_crDir cr) + f = set randGen g + +turnToward'' :: Float -> Point2 -> Int -> World -> World +turnToward'' turnSpeed p n w + | isLeftOfA dirToTarget (_crDir cr) + = f $ over (creatures . ix n . crDir) (normalizeAngle. (+ (turnSpeed + r))) w + | otherwise = f $ over (creatures . ix n . crDir) (\x->normalizeAngle (x - (turnSpeed + r))) w + where cr = _creatures w IM.! n + dirToTarget = argV (p -.- _crPos cr) + (r,g) = randomR (-0.1,0.1) (_randGen w) + f = set randGen g + +crTurnAndStrafeIn :: Float -> Float -> Point2 -> Creature -> Creature +crTurnAndStrafeIn strafeSpeed turnSpeed p cr + | vToTarg == (0,0) = cr -- this should deal with the angleVV error + | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed + = set crDir dirToTarget cr + | isLeftOfA dirToTarget (_crDir cr) + = over crDir (normalizeAngle . (+ turnAmount )) + $ crStrafeLeft strafeSpeed cr + | otherwise = over crDir (\x->normalizeAngle (x - turnAmount)) + $ crStrafeRight strafeSpeed cr + where vToTarg = p -.- _crPos cr + dirToTarget = argV vToTarg + turnAmount = turnSpeed + +crTurnTo :: Point2 -> Creature -> Creature +crTurnTo p cr = set crDir dirToTarget cr + where dirToTarget = argV (p -.- _crPos cr) + +crTurnTowardSpeed :: Float -> Point2 -> Creature -> Creature +crTurnTowardSpeed turnSpeed p cr + | vToTarg == (0,0) = cr -- this should deal with the angleVV error + | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed + = set crDir dirToTarget cr + | isLeftOfA dirToTarget (_crDir cr) + = over crDir (normalizeAngle . (+ turnAmount )) cr + | otherwise = over crDir (\x->normalizeAngle (x - turnAmount)) cr + where vToTarg = p -.- _crPos cr + dirToTarget = argV vToTarg + turnAmount = turnSpeed + +turnTowardSpeed :: Float -> Point2 -> Int -> World -> World +turnTowardSpeed turnSpeed p n w + | vToTarg == (0,0) = w -- this should deal with the angleVV error + | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed + = set (creatures . ix n . crDir) dirToTarget w + | isLeftOfA dirToTarget (_crDir cr) + = over (creatures . ix n . crDir) (normalizeAngle . (+ turnAmount )) w + | otherwise = over (creatures . ix n . crDir) (\x->normalizeAngle (x - turnAmount)) w + where cr = _creatures w IM.! n + vToTarg = p -.- _crPos cr + dirToTarget = argV vToTarg + turnAmount = turnSpeed + +turnLRS :: Int -> World -> World +turnLRS n w = f $ over (creatures . ix n . crDir) (+ (fromIntegral r * pi / 2)) w + where (r,g) = randomR (negate 1::Int,1) (_randGen w) + f = set randGen g + +turnToward' :: Point2 -> Int -> World -> World +turnToward' p n w | isLeftOfA dirToTarget (_crDir cr) + = over (creatures . ix n . crDir) (+ 0.03) w + | otherwise = over (creatures . ix n . crDir) (\x-> x - 0.03) w + where cr = _creatures w IM.! n + dirToTarget = argV (p -.- _crPos cr) + +overturnToward :: Point2 -> Int -> World -> World +overturnToward p n w + | isLeftOfA dirToTarget (_crDir cr) + = over (creatures . ix n . crDir) (normalizeAngle. (+ 0.03 )) w + | otherwise = over (creatures . ix n . crDir) (\x->normalizeAngle (x - 0.03 )) w + where cr = _creatures w IM.! n + dirToTarget = argV (p -.- _crPos cr) + +moveForward :: Int -> World -> World +moveForward n w = over (creatures . ix n . crPos) (+.+ p) w + where p = unitVectorAtAngle $ _crDir $ _creatures w IM.! n + +moveToward :: Point2 -> Int -> World -> World +moveToward p n w + | angle < 10 = moveForwardSpeed 0.1 n w + | angle < 20 = moveForwardSpeed 0.02 n w + | angle < 40 = moveForwardSpeed 0.01 n w + | otherwise = w + where angle = errorAngleVV 5 (p -.- curPos) (unitVectorAtAngle (_crDir (_creatures w IM.! n))) + curPos = _crPos (_creatures w IM.! n) + +moveBy :: Int -> Point2 -> World -> World +moveBy n v = over (creatures . ix n . crPos) (+.+ v) + +reloadWeapon :: Int -> World -> Maybe World +reloadWeapon cid w = if _unlimitedAmmo w then reloadWeaponUnlimited cid w + else reloadWeaponAmmoCheck cid w + +reloadWeaponUnlimited :: Int -> World -> Maybe World +reloadWeaponUnlimited cid w = + let cr = _creatures w IM.! cid + it = _crInv cr IM.! _crInvSel cr + itRef = creatures . ix cid . crInv . ix (_crInvSel cr) + in case it of + Weapon {_wpMaxAmmo=maxA,_wpLoadedAmmo=lA,_wpReloadState=rS,_wpReloadTime=rT} + | lA < maxA && rS == 0 -> Just $ set ( itRef . wpLoadedAmmo) maxA + $ set ( itRef . wpReloadState) rT w + _ -> Nothing + +reloadWeaponAmmoCheck :: Int -> World -> Maybe World +reloadWeaponAmmoCheck cid w = + let cr = _creatures w IM.! cid + it = _crInv cr IM.! _crInvSel cr + itRef = creatures . ix cid . crInv . ix (_crInvSel cr) + in case it of + Weapon {_wpMaxAmmo=maxA,_wpLoadedAmmo=lA,_wpAmmoType=aT + ,_wpReloadState=rS ,_wpReloadTime=rT} + -> do guard $ lA < maxA && rS == 0 && M.findWithDefault 0 aT (_crAmmo cr) > 0 + toAdd <- Just $ min (_crAmmo (you w) M.! aT) (maxA - lA) + return $ over (creatures . ix cid . crAmmo) (M.adjust (\x -> x - toAdd) aT) + $ over ( itRef . wpLoadedAmmo) (\x -> x + toAdd) + $ set ( itRef . wpReloadState) rT w + _ -> Nothing + + +useItemContinuous :: Int -> World -> World +useItemContinuous n w = case (_crInv cr IM.! _crInvSel cr) ^? itHammer of + Just HammerUp -> useItem1 n $ setHammerDown w + Just NoHammer -> useItem1 n w + _ -> setHammerDown w + where + cr = _creatures w IM.! n + setHammerDown = creatures . ix n . crInv . ix (_crInvSel cr) . itHammer .~ HammerDown + +tryUseItem :: Int -> World -> World +tryUseItem cid w = case w ^? creatures . ix cid of + Just cr -> useItem2 cid (_crInv cr IM.! _crInvSel cr) w + Nothing -> w + +useItem1 :: Int -> World -> World +useItem1 n w = useItem2 n it w + where c = (_creatures w IM.! n) + it = _crInv c IM.! _crInvSel c + +useItem2 :: Int -> Item -> World -> World +useItem2 n (Consumable {_cnEffect=eff }) w = fromMaybe w $ fmap (rmInvItem n) $ eff n w +useItem2 n (Weapon {_wpFire=eff}) w = eff n w +useItem2 n (Throwable {_twFire = eff}) w = eff n w +useItem2 _ _ w = w + +rmInvItem :: Int -> World -> World +rmInvItem n w = + let i = _crInvSel (_creatures w IM.! n) + item = _crInv (_creatures w IM.! n) IM.! i + itRef = creatures . ix n . crInv . ix i + in case item of + Consumable {_itAmount = 1} -> set itRef NoItem w + Craftable {_itAmount = 1} -> set itRef NoItem w + Equipment {_itAmount = 1} -> set itRef NoItem w + Throwable {_itAmount = 1} -> set itRef NoItem w + Consumable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w + Craftable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w + Equipment {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w + Throwable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w + _ -> set itRef NoItem w + +dropItem :: World -> World +dropItem w = case yourItem w of + NoItem -> w + it -> rmInvItem (_yourID w) $ over floorItems (IM.insert flid theflit) + $ updateLocation + $ soundOnce putDownSound + $ set randGen g w + where (rot, g) = randomR (-pi,pi) $ _randGen w + offset = _crRad (you w) *.* unitVectorAtAngle rot + updateLocation w = case it ^? itID of + Just (Just i) -> w & itemPositions . ix i .~ OnFloor flid + _ -> w + flid = newKey $ _floorItems w + theflit = FlIt {_flIt = set itAmount 1 it + ,_flItPos = offset +.+ _crPos (you w) + ,_flItRot = rot + ,_flItID = flid} + +useItemAmmoCheck :: Int -> World -> World +useItemAmmoCheck n w + | hasAmmo = useItem1 n w + | otherwise = w + where c = _creatures w IM.! n + hasAmmo = case _crInv c IM.! _crInvSel c of + Weapon {_wpLoadedAmmo=0, _wpAmmoType=ammoT} + -> case _crAmmo c M.!? ammoT of + Just x -> x > 0 + _ -> False + Weapon {} -> True + _ -> False + + +closestItem :: World -> Maybe Int +closestItem w = fmap fst $ listToMaybe $ sortBy cf $ IM.toList + $ fmap (dist yourP . _flItPos) $ _floorItems w + where yourP = _crPos $ you w + cf (_,x) (_,y) = compare x y + +pickUpItem' :: FloorItem -> World -> World +pickUpItem' flit w = case maybeInvSlot of + Nothing -> w + Just i -> soundOnce pickUpSound + $ updateItLocation i + $ w & floorItems %~ IM.delete (_flItID flit) + & creatures . ix 0 . crInv . ix i %~ addItem' it + where + it = _flIt flit + maybeInvSlot = checkInvSlots it (_crInv (_creatures w IM.! 0)) + updateItLocation invid w' + = case _itID it of Nothing -> w' + Just j -> w' & itemPositions . ix j .~ InInv 0 invid + +checkInvSlots :: Item -> IM.IntMap Item -> Maybe Int +checkInvSlots it its = fmap fst $ find cond $ IM.toList its + where cond (_,NoItem) = True + cond (_,it' ) = itNotFull it' && _itName it == _itName it' + +addItem' :: Item -> Item -> Item +addItem' it NoItem = it +addItem' it it' = it' & itAmount +~ 1 + +numInventorySlots :: Int +numInventorySlots = 9 + +itNotFull :: Item -> Bool +itNotFull it = _itMaxStack it > _itAmount it + +createItemAt :: Point2 -> FloorItem -> World -> World +createItemAt p it w = over floorItems (IM.insert i (set flItPos p + $ set flItID i it)) w + where i = newKey (_floorItems w) + +blinkAction :: Int -> World -> World +blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3 + $ blinkShockwave p3 + $ inverseShockwaveAt cp 40 2 2 2 + w + where p1 = _cameraPos w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w) + cp = _crPos $ _creatures w IM.! n + p2 = collidePointWalls cp p1 $ wallsAlongLine cp p1 w + r = 1.5 * _crRad (_creatures w IM.! n) + p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2) + +blinkShockwave :: Point2 -> World -> World +blinkShockwave p = makeShockwaveAt p 40 1 2 cyan + +moveAmountToward :: Point2 -> Float -> Point2 -> Point2 +moveAmountToward p1 am p2 + = p1 +.+ am *.* errorNormalizeV 44 (p2 -.- p1) + +facePointAI :: Point2 -> Int -> World -> World +facePointAI p n w = set (creatures . ix n . crDir) + (argV (p -.- _crPos (_creatures w IM.! n)) ) + w + +reverseDir :: Int -> World -> World +reverseDir n = over (creatures . ix n . crDir) (+ pi) + +turnBy :: Float -> Int -> World -> World +turnBy a n = over (creatures . ix n . crDir) (+ a) diff --git a/src/Dodge/CreatureState.hs b/src/Dodge/CreatureState.hs new file mode 100644 index 000000000..800472fce --- /dev/null +++ b/src/Dodge/CreatureState.hs @@ -0,0 +1,245 @@ +module Dodge.CreatureState where +-- imports {{{ +import Dodge.Data +import Dodge.Base +import Dodge.SoundLogic +import Dodge.RandomHelp +import Dodge.WorldActions +import Dodge.WallCreatureCollisions +import Dodge.CreatureActions + +import Geometry + +import Data.List +import Data.Char +import Data.Maybe +import Data.Function +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.PatriciaTree +import Data.Graph.Inductive.Query.SP +import Codec.BMP +import qualified Data.ByteString as B +import Control.Lens +import Control.Applicative +import Control.Monad.State +import Control.Monad +import qualified SDL as SDL +import qualified SDL.Mixer as Mix +import System.Random +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import qualified Data.Map as M + +import Foreign.ForeignPtr +import Control.Concurrent +---} + +type CRUpdate = World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) + +-- the movement is updated before the ai in order to correctly set the oldpos +-- the whole of this update cycle could do with a rethink, it is becoming +-- convoluted +stateUpdate :: CRUpdate -> CRUpdate +stateUpdate u w (f,g) cr = case u w (f,g) (updateMovement g cr) of + ((f',g') , maybeCr) -> ( (invSideEff cr . movementSideEff cr . dropifdead . f' + , g') + , fmap (updateReloadCounter . reducePastDamage . doDamage) + $ crOrCorpse =<< maybeCr + ) + where + crOrCorpse cr | cr ^. crHP > 0 = Just cr + | otherwise = Nothing + dropifdead | cr ^.crHP > 0 = id + | otherwise = stopSoundFrom (CrWeaponSound (_crID cr)) + . over decorations addCorpse + . insertIt + crBeforeDeath = colCrWall w $ cr +-- addCorpse = insertNewKey $ uncurry translateDrawing (_crPos crBeforeDeath) + addCorpse = insertNewKey $ uncurry translateDrawing (_crOldPos cr) + $ rotateDrawing (radToDeg (_crDir cr)) + (_crCorpse cr) + maybeIt = evalState (maybeTakeOne $ IM.elems (_crInv cr)) (_randGen w) + insertIt = case maybeIt of +-- Just it -> createItemAt (offset +.+ _crPos crBeforeDeath) + Just it -> createItemAt (offset +.+ _crOldPos cr) + (FlIt {_flIt=it,_flItPos=(0,0),_flItRot=rot,_flItID=0}) + Nothing -> id + offset = _crRad cr *.* unitVectorAtAngle rot + (rot,_) = randomR (-pi,pi) g + + +setOldPos :: Creature -> Creature +setOldPos cr = set crOldPos (_crPos cr) cr + +doDamage :: Creature -> Creature +doDamage cr = set (crState . crDamage) [] $ over (crState . crPastDamage) (+ hpLost) + damagedCr + where dams = _crDamage $ _crState cr + startHP = _crHP cr + damagedCr = snd $ (_crApplyDamage (_crState cr)) dams cr +-- applyDamage (cr ^. crState . crDamage) cr + afterHP = _crHP damagedCr + hpLost = startHP - afterHP -- note this can be negative +-- applyDamage :: DamageType -> Creature -> Creature +-- applyDamage dt cr = snd $ (cr ^. crState . crApplyDamage) dt cr + +sumDamage :: Creature -> DamageType -> Int -> Int +sumDamage cr dm x = x + _dmAmount dm + +reducePastDamage :: Creature -> Creature +reducePastDamage = over (crState . crPastDamage) rdpdam + where rdpdam x | x > 500 = x - 55 + | x > 200 = x - 25 + | x > 20 = x - 5 + | x > 0 = x - 1 + | otherwise = 0 + + + +movementSideEff :: Creature -> World -> World +movementSideEff cr w + | hasJetPack + = case cr ^? crState . stance . carriage of + Just (Boosting v) + -> makeFlamelet (oldPos +.+ (_crRad cr + 3) *.* (unitVectorAtAngle $ _crDir cr + pi)) + (momentum +.+ 1 *.* rotateV randDir (vInverse v)) + 66 + Nothing + 1 +-- $ smokeGen v + $ set randGen g + w + _ -> w + | otherwise = case cr ^? crState . stance . carriage of + Just (Walking x y) -> takeStep x y w + _ -> w + where hasJetPack = any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr + oldPos = _crOldPos cr + momentum' = 0.97 *.* (_crPos cr -.- _crOldPos cr) + momentum'' | magV momentum' > 3 = 3 *.* normalizeV momentum' + | otherwise = momentum' + momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng + (randDir,g) = randomR (-0.5,0.5) $ _randGen w + (randAng,_) = randomR (0,2*pi) $ _randGen w + + (v1:v2:v3:_) = fst $ runState ((sequence . repeat . randInCirc) 0.1) $ _randGen w + (r1:r2:r3:_) = map ((*.*) 100) (v2:v3:v1:[]) + (t1:t2:t3:_) = randomRs ( 15,20) $ _randGen w + (s1:s2:s3:_) = map (\s -> fromIntegral s * 0.1 - 1) (t3:t2:t1:[]) + smokeGen v = makeSmokeAt'' v1 s1 t1 + (r1 +.+ oldPos +.+ ((_crRad cr + 3) *.* vInverse (unitVectorAtAngle $ _crDir cr))) + + crHasMoved = dist (_crPos cr) (_crOldPos cr) > 0.5 + takeStep x y | crHasMoved && x < 20 && x + y >= 20 = soundMultiFrom footor 22 3 0 + | crHasMoved && x < 80 && x + y >= 80 = soundMultiFrom footor 23 3 0 + | otherwise = id + footor = [FootstepSound 0,FootstepSound 1] + +invSideEff :: Creature -> World -> World +invSideEff cr w = weaponReloadSounds cr $ IM.foldrWithKey f w (_crInv cr) + where f i it w' = case it ^? itEffect . itInvEffect of + Nothing -> w' + Just g -> g cr i w' + +weaponReloadSounds :: Creature -> World -> World +weaponReloadSounds cr w = case _crInv cr IM.!? _crInvSel cr of + Just (Weapon {_wpReloadState = 0}) + -> w + Just (Weapon {_wpReloadState = 1}) + -> stopSoundFrom (CrReloadSound cid) w + Just (Weapon {}) + -> soundFrom (CrReloadSound cid) reloadSound (1) 0 w + _ + -> w + where cid = _crID cr + +updateMovement :: StdGen -> Creature -> Creature +updateMovement g cr + | isFrictionless cr = over crPos (+.+ momentum) + $ setOldPos + cr + | otherwise + = case cr ^? crState . stance . carriage of + Just (Walking x y) + -> set (crState . stance . carriage) (Walking ((x+y)`mod`120) 0) + $ setOldPos + cr + _ -> set (crState . stance . carriage) (Walking 0 0) + $ setOldPos + cr + where + momentum' = 0.97 *.* (_crPos cr -.- _crOldPos cr) + momentum'' | magV momentum' > 3 = 3 *.* normalizeV momentum' + | otherwise = momentum' + momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng + (randAng,_) = randomR (0,2*pi) g + +isFrictionless :: Creature -> Bool +isFrictionless cr = case cr ^? crState . stance . carriage of + Just (Boosting _) -> True + Just (Floating) -> True + _ -> False + +updateReloadCounter :: Creature -> Creature +updateReloadCounter cr = over (crInv . ix iSel . wpFireState) decreaseToZero + . over (crInv . ix iSel . wpReloadState) decreaseToZero + $ cr + where iSel = _crInvSel cr + +decreaseToZero :: Int -> Int +decreaseToZero x | x > 0 = x - 1 + | otherwise = 0 + +updateBarrel :: + World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature) +updateBarrel w (f,g) cr | _crHP cr > 0 = ((f, g), newCr) + | otherwise = ((f, g), Nothing) +-- | otherwise = ((makeExplosionAt (_crPos cr) . stopSounds , g'), Nothing) + where damages = _crDamage $ _crState cr + newCr = Just $ doDamage cr + +-- it is easy to leave off the "f" here +-- should find some better way of doing all this that is less prone to error +updateExpBarrel :: + World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature) +updateExpBarrel w (f,g) cr + | _crHP cr > 0 = ((f . foldr (.) id pierceSparks . hiss, g'), newCr) + | otherwise = ((f . makeExplosionAt (_crPos cr) . stopSounds , g'), Nothing) + where damages = _crDamage $ _crState cr + pierceSparks :: [World -> World] + pierceSparks + = zipWith4 (\p a colid time-> (createBarrelSpark time colid (_crPos cr +.+ p) (a + argV p)) + (Just $ _crID cr)) + poss as colids times + as = randomRs (-0.7,0.7) $ g + colids = randomRs (0,11) $ g + times = randomRs (2,5) $ g + (g',_) = split g + poss = _piercedPoints $ _crSpState $ _crState cr + --newCr = Just $ doDamage $ applyFuseDamage cr -- $ foldr perforate cr damages + newCr = Just $ applyFuseDamage $ set (crState . crDamage) [] $ damToExpBarrel damages cr + perforate :: DamageType -> Creature -> Creature + perforate (Piercing amount sp int ep) cr = over (crState . crSpState . piercedPoints) + ((:) $ int -.- _crPos cr) cr + perforate _ cr = cr + applyFuseDamage cr = over crHP (\hp -> hp - length (_piercedPoints + $ _crSpState $ _crState cr)) + cr + hiss | poss == [] = id + | otherwise = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] 41 50 1 + stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1) + +damToExpBarrel :: [DamageType] -> Creature -> Creature +damToExpBarrel ds cr = foldr damToExpBarrel' (foldr damToExpBarrel' cr pierceDam) otherDam + where (pierceDam,otherDam) = partition isPierce ds + isPierce (Piercing {}) = True + isPierce _ = False + +damToExpBarrel' :: DamageType -> Creature -> Creature +damToExpBarrel' (Piercing amount sp int ep) cr + = over (crState . crSpState . piercedPoints) ((:) $ int -.- _crPos cr) + $ over crHP (\hp -> hp - div amount 200) cr +damToExpBarrel' (PoisonDam {}) cr = cr +damToExpBarrel' (SparkDam {}) cr = cr +damToExpBarrel' (PushDam {_dmPushBack = v}) cr = cr Control.Lens.& crPos %~ (+.+) (1 / _crMass cr *.* v) +damToExpBarrel' dt cr = cr Control.Lens.& crHP -~ _dmAmount dt diff --git a/src/Dodge/Critters.hs b/src/Dodge/Critters.hs new file mode 100644 index 000000000..f5565edb5 --- /dev/null +++ b/src/Dodge/Critters.hs @@ -0,0 +1,399 @@ +module Dodge.Critters where +-- imports {{{ +import Dodge.Data +import Dodge.Weapons +import Dodge.AIs +import Dodge.CreatureState +import Dodge.Prototypes +import Dodge.Base +import Dodge.Smoke + +import Picture +import Geometry + +import Data.List +import Data.Char +import Data.Maybe +import Data.Function +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.PatriciaTree +import Codec.BMP +import qualified Data.ByteString as B +import Control.Lens +import Control.Applicative +import Control.Monad.State +import Control.Monad +import System.Random +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import qualified Data.Map as M +import Foreign.ForeignPtr +import Control.Concurrent +---} + +--colouredEnemy col = pictures [color (greyN 0.8) $ circleSolid 10, color col $ circLine 10] +colouredEnemy col = pictures [color col $ circleSolid 10, circLine 10] + + +-- armouredSwarmCrit :: Int -> Creature +-- armouredSwarmCrit n = (basicCreature n) +-- -- { _crUpdate = encircleAI' n +-- { _crUpdate = swarmAI lineOrth n +-- , _crHP = 30 +-- , _crPict = equipOnTop goalPict +-- , _crState = basicState {_goals = [[]], _faction = EncircleFlock} +-- , _crInv = IM.fromList [(0,frontArmour)] +-- } +-- +-- swarmCrit :: Int -> Creature +-- swarmCrit n = (basicCreature n) +-- -- { _crUpdate = encircleAI' n +-- { _crUpdate = swarmAI lineOrth n +-- , _crHP = 30 +-- , _crPict = equipOnTop goalPict +-- , _crState = basicState {_goals = [[]], _faction = EncircleFlock} +-- , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] +-- } +-- +-- encircleCrit :: Int -> Creature +-- encircleCrit n = (basicCreature n) +-- -- { _crUpdate = encircleAI' n +-- { _crUpdate = swarmAI lineOrth n +-- , _crHP = 30 +-- , _crPict = equipOnTop goalPict +-- , _crState = basicState {_goals = [[]], _faction = EncircleFlock} +-- , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] +-- } +-- +spawnerCrit :: Creature +spawnerCrit = basicCreature + { _crUpdate = stateUpdate $ spawnerAI chaseCrit + , _crHP = 300 + , _crPict = enemyPict blue + , _crState = basicState {_goals = [[WaitFor 0]] + } + , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] + } +-- +-- guardMelee :: Int -> Creature +-- guardMelee n = (basicCreature n) +-- { _crUpdate = meleeAI' n +-- , _crHP = 30 +-- , _crPict = equipOnTop goalPict +-- , _crState = basicState {_goals = [[InitGuard]] +-- ,_faction = ChaseCritters} +-- , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] +-- } +smallChaseCrit :: Creature +smallChaseCrit = basicCreature + { _crUpdate = stateUpdate chaseAI + , _crHP = 1 + , _crRad = 4 + --, _crPict = equipOnTop goalPict + , _crPict = enemyPict green + , _crState = basicState {_goals = [[Wait]] + ,_faction = ChaseCritters} + , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] + , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 4 + } +chaseCrit :: Creature +chaseCrit = basicCreature + { _crUpdate = stateUpdate chaseAI + , _crHP = 300 +-- , _crPict = goalPict -- enemyPict green + , _crPict = enemyPict green + , _crState = basicState {_goals = [[Wait]] + ,_faction = ChaseCritters} + , _crInv = IM.empty + -- IM.fromList [(0,frontArmour)] + } +armourChaseCrit :: Creature +armourChaseCrit = basicCreature + { _crUpdate = stateUpdate chaseAI + , _crHP = 300 + , _crPict = enemyPict green + , _crState = basicState {_goals = [[Wait]]} + , _crInv = IM.fromList [(0,frontArmour)] + } +miniGunCrit :: Creature +miniGunCrit = basicCreature + { _crPict = enemyPict red + --, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n + , _crUpdate = stateUpdate miniAI + --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n + , _crInv = IM.fromList [(0,miniGun)] + , _crInvSel = 0 + , _crRad = 10 + , _crAmmo = M.fromList [(PistolBullet, 1000)] + --, _crState = ShooterWait + , _crState = basicState {_goals = [[InitGuard]]} + , _crHP = 500 + } +longCrit :: Creature +longCrit = basicCreature + { _crPict = enemyPict red + --, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n + , _crUpdate = stateUpdate sniperAI + --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n + , _crInv = IM.fromList [(0,longGun),(1,medkit 100)] + , _crInvSel = 0 + , _crRad = 10 + , _crAmmo = M.fromList [(PistolBullet, 1000)] + --, _crState = ShooterWait + , _crState = basicState {_goals = [[InitGuard]]} + , _crHP = 300 + } +multGunCrit :: Creature +multGunCrit = basicCreature + { _crPict = enemyPict red + --, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n + , _crUpdate = stateUpdate (twitchMissAI 300 350) + --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n + , _crInv = IM.fromList [(0,multGun),(1,medkit 100)] + , _crInvSel = 0 + , _crRad = 10 + , _crAmmo = M.fromList [(PistolBullet, 1000)] + --, _crState = ShooterWait + , _crState = basicState {_goals = [[InitGuard]]} + , _crHP = 300 + } +launcherCrit :: Creature +launcherCrit = basicCreature + { _crPict = enemyPict red + --, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n + , _crUpdate = stateUpdate (launcherAI 150 200) + --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n + , _crInv = IM.fromList [(0,launcher),(1,medkit 100)] + , _crInvSel = 0 + , _crRad = 10 + , _crAmmo = M.fromList [(PistolBullet, 1000)] + --, _crState = ShooterWait + , _crState = basicState {_goals = [[Init]]} + , _crHP = 300 + } +spreadGunCrit :: Creature +spreadGunCrit = basicCreature + { _crPict = enemyPict red + --, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n + , _crUpdate = stateUpdate chargeAI + --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n + , _crInv = IM.fromList [(0,spreadGun),(1,medkit 100)] + , _crInvSel = 0 + , _crRad = 10 + , _crAmmo = M.fromList [(PistolBullet, 1000)] + --, _crState = ShooterWait + , _crState = basicState {_goals = [[Init]]} + , _crHP = 300 + } +pistolCrit :: Creature +pistolCrit = basicCreature + { _crPict = enemyPict red + --, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n + , _crUpdate = stateUpdate (dodgeAI 150 200) + --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n + , _crInv = IM.fromList [(0,pistol),(1,medkit 100)] + , _crInvSel = 0 + , _crRad = 10 + , _crAmmo = M.fromList [(PistolBullet, 1000)] + --, _crState = ShooterWait + , _crState = basicState {_goals = [[InitGuard]]} + , _crHP = 500 + } +autoCrit :: Creature +autoCrit = basicCreature + { _crPict = enemyPict red + --, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n + , _crUpdate = stateUpdate basicShooterAI + --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n + , _crInv = IM.fromList [(0,autoGun),(1,medkit 100)] + , _crInvSel = 0 + , _crRad = 10 + , _crAmmo = M.fromList [(PistolBullet, 1000)] + --, _crState = ShooterWait + , _crState = basicState {_goals = [[InitGuard]]} + , _crHP = 300 + } +addArmour :: Creature -> Creature +addArmour = over crInv insarmour + where insarmour xs = IM.insert i frontArmour xs + where i = newKey xs +--closeShooterCrit :: Int -> Creature +--closeShooterCrit n = (basicCreature n) +-- { _crPos = startPos +-- , _crPict = equipOnTop goalPict +-- , _crUpdate = closeShooterAI n +-- , _crInv = IM.fromList [(0,ltAutoGun)] +-- , _crInvSel = 0 +-- , _crRad = 10 +-- , _crAmmo = M.fromList [(PistolBullet, 1000)] +-- , _crState = basicState {_goals = [[InitGuard]]} +-- , _crHP = 50 +-- } +-- where startPos = (20*fromIntegral n-550,0) +barrel :: Creature +barrel = basicCreature + { _crUpdate = updateBarrel + , _crHP = 500 + , _crPict = \ _ -> onLayer CrLayer $ pictures [ color orange $ circleSolid 10 + , color (greyN 0.5) $ circleSolid 8 + ] + , _crState = basicState {_goals = [[Wait]] + ,_faction = ChaseCritters + ,_crSpState = Barrel [] + } + , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] + } + +explosiveBarrel :: Creature +explosiveBarrel = basicCreature + { _crUpdate = updateExpBarrel + , _crHP = 400 + , _crPict = \ _ -> onLayer CrLayer $ pictures [ color orange $ circleSolid 10 + , color red $ circleSolid 8 + ] + , _crState = basicState {_goals = [[Wait]] + ,_faction = ChaseCritters + ,_crSpState = Barrel [] + ,_crApplyDamage = \_ c -> (id, c) + } + , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] + } + +equipOnTop :: (Creature -> Picture) -> Creature -> Drawing +--equipOnTop f cr = onLayer CrLayer $ pictures $ fst (drawEquipment cr) ++ [f cr] ++ snd (drawEquipment cr) +equipOnTop f cr = onLayer CrLayer (f cr) <> drawEquipment cr + +drawEquipment :: Creature -> Drawing +drawEquipment cr = mconcat $ map f $ IM.toList (_crInv cr) + where f (i,it) = case it ^? itEquipPict of + Just g -> g cr i + _ -> blank + +--drawEquipment :: Creature -> ([Picture],[Picture]) +--drawEquipment cr = (map fst p1, map fst p2) +-- where f (k,it) = join $ (it ^? itEquipPict) <*> (pure cr) <*> (pure k) +-- picts = sortBy (compare `on` snd) $ mapMaybe f $ IM.toList (_crInv cr) +-- (p1,p2) = partition (\ x -> snd x < 0) picts + +frontArmouredPict = const $ pictures [ color (greyN 0.8) $ circleSolid 20 + , color red $ circLine 20 +-- ,color (greyN 0.1) $ thickArc 0 90 20 5 +-- ,color (greyN 0.1) $ thickArc 270 360 20 5 + ] + +--packCrits :: (Int -> World -> World) -> [Int] -> [Creature] +--packCrits ai is = [(basicCreature i) +-- { _crPos = (150,10+20*fromIntegral i) +-- , _crPict = swarmPict +-- , _crUpdate = ai i +-- --, _crUpdate = swarmAI is i +-- , _crRad = 3 +-- , _crHP = 1 +-- , _crMass = 2 +-- } +-- | i <- is] + +--queenBeeCrit :: Int -> Creature +--queenBeeCrit cID = (basicCreature cID) +-- { _crRad = 20 +-- , _crCorpse = color (greyN 0.5) $ circleSolid 20 +-- , _crPict = const $ pictures [color black $ circSolid 20 +-- ,color yellow $ circLine 20 +-- ] +-- , _crUpdate = checkDead cID . makeStateAI queenBeeAI cID +-- , _crState = QueenBee 0 20 +-- , _crMass = 20 +-- } + +--antCrit :: Int -> Creature +--antCrit cID = (basicCreature cID) +-- { _crPos = (0,100 + 3 * fromIntegral cID) +-- , _crUpdate = checkDead cID . makeStateAI (antAI 2) cID +-- , _crState = AntMove 50 +-- , _crPict = antPic +-- , _crRad = 3 +-- , _crHP = 1 +-- , _crMass = 2 +-- , _crCorpse = color (greyN 0.5) $ circSolid 3 +-- } +-- where i = evalState (state (randomR (1::Int,100))) (mkStdGen cID) +--antPic = const $ pictures [ translate (-1) 0 $ circleSolid 2 +-- , translate (2) 0 $ circleSolid 1 +-- , translate (1) 0 $ circleSolid 1 +-- , line [(3,3),(-3,-3)] +-- , line [(-3,3),(3,-3)] +-- , line [(0,-3),(0,3)] +-- ] + +flamerPict = const $ pictures [color (light $ light $ light $ dim blue) $ circleSolid 10, circLine 10] + + + +goalPict cr = let r = _crRad cr in case _crState cr of + CrSt {_goals = gls ,_crDamage = crDam } +-- | crDam > _crHP cr -> color white $ circleSolid r + | otherwise -> case head gls of + [] -> sizeColEnemy r white + (MoveToFor p i:_) -> dGoals $ sizeColEnemy r green + (WaitFor x:_) -> dGoals $ sizeColEnemy r yellow + (FireAt p:_) -> dGoals $ sizeColEnemy r red + (Reload:_) -> dGoals $ sizeColEnemy r orange + (PathTo p:_) -> dGoals $ sizeColEnemy r cyan + (SubPathTo p i _:_) -> dGoals $ sizeColEnemy r blue + (Search i:_) -> dGoals $ sizeColEnemy r black + _ -> dGoals $ sizeColEnemy r magenta + where dGoals p = pictures [p, rotate (radToDeg (_crDir cr)) $ scale 0.1 0.1 $ color white $ text $ show gls] + _ -> sizeColEnemy r (light $ dim green) + +startCr :: Creature +startCr = basicCreature + { _crPos = (0,0) + , _crOldPos = (0,0) + , _crDir = 0 + , _crID = 0 + , _crPict = basicCrPict $ greyN 0.8 + + , _crUpdate = stateUpdate yourControl + , _crRad = 10 + , _crMass = 10 + , _crHP = 10000 + , _crMaxHP = 1500 + , _crInv = IM.fromList (zip [0..20] + ([pistol,autoGun,launcher,lasGun,grenade + ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher + ,longGun + ,hvAutoGun + ,teslaGun + ,latchkey 0 + ] + ++ repeat NoItem)) + -- startInv + , _crAmmo = M.fromList [(PistolBullet, 0),(LiquidFuel, 100),(Battery, 20000),(Shell,200)] + , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10] + } + +smokeGenGun = effectGun "smoke" $ \_ -> spawnSmokeAtCursor + +enemyPict :: Color -> Creature -> Drawing +enemyPict col = equipOnTop $ sizeEnemy (light $ light $ light $ light col) + +sizeEnemy col cr + | pdam > 200 = color red $ circleSolid $ _crRad cr + | pdam > 100 = color white $ circleSolid $ _crRad cr + | mod pdam 2 == 1 = color white $ circleSolid $ _crRad cr + | otherwise = pictures [color col $ circleSolid $ _crRad cr + , circLine $ _crRad cr ] + where pdam = _crPastDamage $ _crState cr + +sizeColEnemy r col = pictures [color col $ circleSolid r, circLine r] + +basicCrPict :: Color -> Creature -> Drawing +basicCrPict col cr = onLayer CrLayer naked <> drawEquipment cr + where naked | pdam > 200 = color red $ circleSolid $ _crRad cr + | pdam > 100 = color white $ circleSolid $ _crRad cr + | mod pdam 2 == 1 = color white $ circleSolid $ _crRad cr + -- | crDam > _crHP cr && odd (crDam - _crHP cr) + -- = [color white $ circleSolid $ _crRad cr] + | otherwise = pictures [color col $ circleSolid $ _crRad cr, circLine $ _crRad cr] +-- , rotate (radToDeg $ _crDir cr) $ scale 0.2 0.2 $ color white $ text $ show $ _crPos cr + pdam = _crPastDamage $ _crState cr diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs new file mode 100644 index 000000000..f76886b62 --- /dev/null +++ b/src/Dodge/Data.hs @@ -0,0 +1,715 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +--{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE StrictData #-} +module Dodge.Data + ( module Dodge.Data + , Point2 (..) + ) + where +-- imports {{{ + +import Picture.Data + +import Geometry.Data + +import Control.Lens +import Control.Monad.State +import System.Random + +import Data.Graph.Inductive +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import qualified Data.Map as M + +import qualified SDL.Mixer as Mix +import SDL (Keycode, MouseButton) +import Graphics.Rendering.OpenGL (PrimitiveMode (..),GLfloat,Program,VertexArrayObject,BufferObject) +import Codec.Picture (Image,PixelRGBA8) + +import qualified Data.DList as DL + +--}}} +-- datatypes {{{ + + + + +data World = World + { _keys :: !(S.Set Keycode) + , _mouseButtons :: !(S.Set MouseButton) + , _cameraPos :: !Point2 + , _cameraAimTime :: Int + , _cameraRot :: !Float + , _cameraZoom :: !Float + , _cameraCenter :: !Point2 + , _creatures :: IM.IntMap Creature + , _creaturesZone :: IM.IntMap (IM.IntMap (IM.IntMap Creature)) + , _itemPositions :: IM.IntMap ItemPos + , _clouds :: IM.IntMap Cloud + , _cloudsZone :: IM.IntMap (IM.IntMap (IM.IntMap Cloud)) + , _particles :: IM.IntMap Particle + , _particles' :: ![Particle'] + , _afterParticles' :: ![Particle'] + , _smoke :: [Smoke] + , _walls :: !(IM.IntMap Wall) + , _wallsZone :: (IM.IntMap (IM.IntMap (IM.IntMap Wall))) + , _forceFields :: IM.IntMap ForceField + , _floorItems :: IM.IntMap FloorItem + , _randGen :: StdGen + , _mousePos :: !(Float,Float) + , _testString :: String + , _yourID :: !Int + , _worldEvents :: !(World -> World) + , _pressPlates :: IM.IntMap PressPlate + , _buttons :: IM.IntMap Button + , _soundQueue :: [Int] +-- , _loadedSounds :: IM.IntMap Mix.Chunk + , _sounds :: M.Map SoundOrigin Sound + , _decorations :: IM.IntMap Drawing + , _corpses :: IM.IntMap (IM.IntMap [Corpse]) + , _lbClickMousePos :: (Float,Float) + , _lbRotation :: Float + , _pathGraph :: ~(Gr Point2 Float) + , _pathGraph' :: ~[(Point2,Point2)] + , _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)])) + , _pathInc :: ~(M.Map Point2 [Point2]) + , _unlimitedAmmo :: Bool + , _storedLevel :: Maybe World + , _menuState :: MenuState + , _worldState :: M.Map WorldState Bool + , _windowX :: Float + , _windowY :: Float + , _mapDisplay :: (Bool, Float) + , _lightSources :: !(IM.IntMap LightSource) + , _tempLightSources :: ![TempLightSource] + } --deriving (Show) + +type Drawing = Picture + +data Corpse = Corpse + { _cpPos :: Point2 + , _cpPict :: Drawing + , _cpRes :: Creature + } + +data Layer = PtLayer | CrLayer | WlLayer | BgLayer | ShadowLayer + | FlItLayer | LabelLayer | InvLayer | MenuLayer + | PressPlateLayer | CorpseLayer + | UPtLayer + | HPtLayer + | GloomLayer + +data Cloud = Cloud + { _clID :: Int + , _clPos :: Point2 + , _clVel :: Point2 + , _clPict :: Cloud -> Drawing + , _clRad :: Float + , _clTimer :: Int + , _clEffect :: Cloud -> World -> World + } + +data LightSource + = LS + { _lsID :: !Int + , _lsPos :: !Point2 + , _lsDir :: !Float + , _lsRad :: !Float + , _lsIntensity :: !Float + } + +data TempLightSource = + TLS { _tlsPos :: !Point2 + , _tlsRad :: !Float + , _tlsIntensity :: !Float + , _tlsUpdate :: World -> TempLightSource -> (World, Maybe TempLightSource) + } + +data Creature = Creature + { _crPos :: Point2 + , _crOldPos :: Point2 + , _crDir :: Float + , _crID :: Int + , _crPict :: Creature -> Drawing + , _crUpdate :: World -> (World -> World,StdGen) -> Creature + -> ((World -> World,StdGen), Maybe Creature) + , _crRad :: Float + , _crMass :: Float + , _crHP :: Int + , _crMaxHP :: Int + , _crInv :: IM.IntMap Item + , _crInvSel :: Int + , _crAmmo :: M.Map Ammo Int + , _crState :: CreatureState + , _crCorpse :: Drawing + } + +data CreatureState + = CrSt { _goals :: [[Goal]] + , _stance :: Stance + , _faction :: Faction + , _crDamage :: [DamageType] + , _crPastDamage :: Int + , _crSpState :: CrSpState + , _crApplyDamage :: [DamageType] -> Creature -> (World -> World,Creature) + } +-- deriving (Eq,Show) +data CrSpState = Barrel { _piercedPoints :: [Point2]} + | GenCr + deriving (Eq,Show,Ord) +data Goal = MoveTo Point2 + | MoveToFor Point2 Int + | MoveFire Point2 Point2 + | PathTo Point2 + | PathAlong [Point2] + | SubPathTo Point2 Int Point2 + | Wait + | WaitFor Int + | WaitForID Int Int + | FireAt Point2 + | FireAtID Int Point2 + | Fire + | Reload + | IncreaseAlert Int + | Guard Point2 Point2 + | Search Int + | SearchNear Point2 + | AimAt Point2 Int + | InitGuard + | Init + | MeleeAttack Int + | InitTrackYou + | TrackYou + | Track Int + | TrackFor Int Int + | TurnByFor Float Int + | TurnTo Point2 + | TurnToward Point2 + | TurnTowardAngle Float + | StrafeLeftAround Int Point2 + | StrafeRightAround Int Point2 + | StrafeLeftFor Int + | StrafeRightFor Int + | StrafeLeftForSpeed Int Float + | StrafeRightForSpeed Int Float + | StrafeLeftFire + | StrafeRightFire + | MoveForwardFor Int + | MoveForwardFire + | MoveBackwardFor Int + | MoveByFor Point2 Int + | MoveBackwardFire + | GoalID Int Goal + | AtRange Float + | AtRanges Float Float + | RepeatAction Int Goal + | MakeJudgement + | SetPosture Posture + deriving (Eq,Show) +data Stance = Stance {_carriage :: Carriage + ,_posture :: Posture + } + deriving (Eq,Show) +data Carriage = Walking {_stepCycle :: Int + ,_stepToAdd :: Int + } + | Floating + | Boosting Point2 + deriving (Eq,Show) +data Posture = Aiming + | AtEase + deriving (Eq,Show) +data Mind = ZombieMind + | HumanMind + deriving (Eq,Show) +data Faction = GenericFaction Int + | ZombieFaction + | EncircleFlock + | ChaseCritters + | SpawnedBy Int + | NoFaction + deriving (Eq,Show) + +-- NOTE: walls must be drawn counterclockwise + +data WorldState = DoorNumOpen Int + | CrNumAlive Int + deriving (Eq,Ord) + +data MenuState + = LevelMenu Int + | PauseMenu + | GameOverMenu + | InGame + +data Sound = Sound { _soundTime :: Int + , _soundFadeTime :: Int + , _soundChannel :: Maybe Int + , _soundPos :: Maybe Point2 + , _soundType :: Int + } + deriving (Eq,Ord,Show) + +data Button = Button + { _btPict :: Drawing + , _btPos :: Point2 + , _btRot :: Float + , _btEvent :: Button -> World -> World + , _btID :: Int + , _btText :: String + , _btState :: ButtonState + } + +data ButtonState = BtOn | BtOff | BtNoLabel + deriving (Eq, Show) + +data PressPlate = PressPlate { _ppPict :: Drawing + , _ppPos :: Point2 + , _ppRot :: Float + , _ppEvent :: PressPlate -> World -> World + , _ppID :: Int + , _ppText :: String + } + +data FloorItem = FlIt { _flIt :: Item , _flItPos :: Point2 , _flItRot :: Float, _flItID :: Int} + | FlAm { _flAm :: Ammo , _flItPos :: Point2 , _flAmNum :: Int , _flItID :: Int} + +data ItemPos = InInv { _itCrId :: Int + , _itInvId :: Int + } + | OnFloor { _itFlID :: Int + } + +data Item = Weapon + { _itName :: String + , _wpMaxAmmo :: Int + , _wpLoadedAmmo :: Int + , _wpAmmoType :: Ammo + , _wpReloadTime :: Int + , _wpReloadState :: Int + , _wpFireRate :: Int + , _wpFireState :: Int + , _wpFire :: Int -> World -> World + , _wpSpread :: Float + , _wpRange :: Float + , _itHammer :: HammerPosition + , _itFloorPict :: Drawing + , _itMaxStack :: Int + , _itAmount :: Int + , _itAimingSpeed :: Float + , _itAimingRange :: Float + , _itZoom :: ItZoom + , _itEquipPict :: Creature -> Int -> Drawing + , _itScrollUp :: Int -> World -> World + , _itScrollDown :: Int -> World -> World + , _itIdentity :: ItemIdentity + , _itAttachment :: Maybe ItAttachment + , _itID :: Maybe Int + , _itEffect :: ItEffect + , _itInvDisplay :: Item -> String + , _itInvColor :: Color + } + | Consumable + { _itName :: String + , _itMaxStack :: Int + , _itAmount :: Int + , _cnEffect :: Int -> World -> Maybe World + , _itFloorPict :: Drawing + , _itEquipPict :: Creature -> Int -> Drawing + , _itIdentity :: ItemIdentity + , _itID :: Maybe Int + , _itInvDisplay :: Item -> String + , _itInvColor :: Color + , _itEffect :: ItEffect + , _itHammer :: HammerPosition + } + | Craftable + { _itName :: String + , _itMaxStack :: Int + , _itAmount :: Int + , _itFloorPict :: Drawing + , _itEquipPict :: Creature -> Int -> Drawing + , _itIdentity :: ItemIdentity + , _itID :: Maybe Int + , _itInvDisplay :: Item -> String + , _itInvColor :: Color + } + | Equipment + { _itName :: String + , _itMaxStack :: Int + , _itAmount :: Int + , _itFloorPict :: Drawing + , _itEquipPict :: Creature -> Int -> Drawing + , _itIdentity :: ItemIdentity + , _itEffect :: ItEffect + , _itID :: Maybe Int + , _itAimingSpeed :: Float + , _itAimingRange :: Float + , _itZoom :: ItZoom + , _itInvDisplay :: Item -> String + , _itInvColor :: Color + , _itHammer :: HammerPosition + } + | Throwable + { _itName :: String + , _itMaxStack :: Int + , _itAmount :: Int + , _itFloorPict :: Drawing + , _twMaxRange :: Float + , _twAccuracy :: Float + , _twFire :: Int -> World -> World + , _itAimingSpeed :: Float + , _itAimingRange :: Float + , _itZoom :: ItZoom + , _itEquipPict :: Creature -> Int -> Drawing + , _itIdentity :: ItemIdentity + , _itID :: Maybe Int + , _itAttachment :: Maybe ItAttachment + , _itInvDisplay :: Item -> String + , _itInvColor :: Color + , _itEffect :: ItEffect + , _itHammer :: HammerPosition + , _itScrollUp :: Int -> World -> World + , _itScrollDown :: Int -> World -> World + } + | NoItem + +data ItAttachment + = ItScope {_scopePos :: Point2 + ,_scopeZoomChange :: Int + ,_scopeZoom :: Float + ,_scopeIsCamera :: Bool + } + | ItFuse {_itFuseTime :: Int} + | ItPhaseV {_itPhaseV :: Float} + | ItMode {_itMode :: Int} + +data ItEffect = NoItEffect + | ItInvEffect {_itInvEffect :: Creature -> Int -> World -> World + ,_itEffectCounter :: Int + } + | ItEffect {_itInvEffect :: Creature -> Int -> World -> World + ,_itFloorEffect :: Int -> World -> World + ,_itEffectCounter :: Int + } +data ItZoom = ItZoom {_itAimZoomMax :: Float + ,_itAimZoomMin :: Float + ,_itAimZoomFac :: Float + ,_itZoomMax :: Float + ,_itZoomMin :: Float + ,_itZoomFac :: Float + } + +data IntID a = IntID Int a + +data HammerPosition = HammerDown + | HammerReleased + | HammerUp + | NoHammer + +data ItemIdentity + = Pistol + | SpreadGun + | MultGun + | HvAutoGun + | AutoGun + | LtAutoGun + | MiniGun + | Medkit25 + | MagShield + | FrontArmour + | JetPack + | FlameShield + | Generic + | SparkGun + | ShatterGun + | LongGun + | Flamethrower + | Blinker + | Grenade + | RemoteBomb + | TeslaGun + | LasGun + | ForceFieldGun + | GrapGun + | TractorGun + | Launcher + | RemoteLauncher + | LightningGun + | PoisonSprayer + deriving (Eq,Show,Ord,Enum) + +data Particle' = + Particle' { _ptPict' :: Drawing + , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle') + } + | Bul' { _ptPict' :: Drawing + , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle') + , _btVel' :: Point2 + , _btColor' :: Color + , _btTrail' :: [Point2] + , _btPassThrough' :: Maybe Int + , _btWidth' :: Float + , _btTimer' :: Int + , _btHitEffect' :: HitEffect' + } + | Pt' { _ptPict' :: Drawing + , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle') + , _btVel' :: Point2 + , _btColor' :: Color + , _btPos' :: Point2 + , _btPassThrough' :: Maybe Int + , _btWidth' :: Float + , _btTimer' :: Int + , _btHitEffect' :: HitEffect' + } + | Shockwave' + { _ptPict' :: Drawing + , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle') + , _btColor' :: Color + , _btPos' :: Point2 + , _btRad' :: Float + , _btDam' :: Int + , _btPush' :: Float + , _btMaxTime' :: Int + , _btTimer' :: Int + } + +type HitEffect = Point2 -> Point2 -> (Point2, (Either3 Creature Wall ForceField)) -> World -> World +type HitEffect' = Particle' -> (Point2, (Either3 Creature Wall ForceField)) -> World -> World + +data Particle = + Particle { _ptPos :: Point2 + , _ptStartPos :: Point2 + , _ptVel :: Point2 + , _ptPict :: Drawing + , _ptID :: Int + , _ptUpdate :: World -> World + } + | Bullet { _ptPos :: Point2 + , _ptVel :: Point2 + , _ptPict :: Drawing + , _ptID :: Int + , _ptUpdate :: World -> World + , _btTrail :: [Point2] + , _btPassThrough :: Maybe Int + , _btColor :: Color + , _btWidth :: Float +-- , _btHitEffect :: Particle -> [(Point2, Either3 Creature Wall ForceField)] -> World -> World + } + | Bullet' + { _ptPos :: Point2 + , _ptVel :: Point2 + , _ptPict :: Drawing + , _ptID :: Int + , _ptUpdate :: World -> World + } + +data DamageType = Piercing {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } + | Blunt {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } + | SparkDam {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } + | Flaming {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } + | Lasering {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } + | Concussive {_dmAmount :: Int , _dmFrom :: Point2 , _dmPush :: Float + , _dmPushExp :: Float + , _dmPushRadius :: Float} + | TorqueDam {_dmAmount :: Int , _dmTorque :: Float } + | PushDam {_dmAmount :: Int , _dmPushBack :: Point2 } + | PoisonDam {_dmAmount :: Int} + deriving (Eq,Ord,Show) + +data Either3 a b c = E3x1 a | E3x2 b | E3x3 c + +data Smoke = + Smoke + { _smPos :: Point2 + , _smRad :: Float + , _smColor :: Color + , _smUpdate :: Smoke -> Maybe Smoke + , _smPs :: [Point2] + , _smTime :: Int + } + +data WLID = WLID { _wlIDx :: Int, _wlIDy :: Int, _wlIDid :: Int} + +data Wall = Wall + { _wlLine :: [Point2] , _wlID :: Int + , _wlColor :: Color + , _wlDraw :: Maybe (Wall -> Drawing) + , _wlSeen :: Bool + , _wlIsSeeThrough :: Bool +-- , _wlID' :: WLID + } + | BlockAutoDoor + { _wlLine :: [Point2] + , _wlID :: Int + , _doorMech :: World -> World + , _wlColor :: Color + , _wlDraw :: Maybe (Wall -> Drawing) + , _wlSeen :: Bool + , _blIDs :: [Int] + , _blHP :: Int + , _wlIsSeeThrough :: Bool +-- , _wlID' :: WLID + } + | AutoDoor + { _wlLine :: [Point2] , _wlID :: Int + , _doorMech :: World -> World + , _wlColor :: Color + , _wlDraw :: Maybe (Wall -> Drawing) + , _wlSeen :: Bool + , _wlIsSeeThrough :: Bool +-- , _wlID' :: WLID +-- , _doorLine :: [Point2] + } + | Door + { _wlLine :: [Point2] , _wlID :: Int + , _doorMech :: World -> World + , _wlColor :: Color + , _wlDraw :: Maybe (Wall -> Drawing) + , _wlSeen :: Bool + , _wlIsSeeThrough :: Bool +-- , _wlID' :: WLID +-- , _doorLine :: [Point2] + } + | Block + { _wlLine :: [Point2] + , _wlID :: Int + , _wlColor :: Color + , _wlDraw :: Maybe (Wall -> Drawing) + , _wlSeen :: Bool + , _blIDs :: [Int] + , _blHP :: Int + , _wlIsSeeThrough :: Bool + , _blVisible :: Bool + , _blShadows :: [Int] + , _blDegrades :: [Int] +-- , _wlID' :: WLID + } + +data Block' = Block' + { _blPoly :: [Point2] + , _blLines :: [[Point2]] + , _blColor :: Color + , _blSeen :: Bool + , _blHP' :: [Int] + , _blVisible' :: Bool + , _blShadows' :: [Int] + , _blID :: Int + } + +data ForceField = FF { _ffLine :: [Point2] , _ffID :: Int + , _ffColor :: Color + , _ffDeflect :: Maybe (StdGen -> Point2 -> ForceField -> (Point2,StdGen)) + , _ffState :: FFState + } +data FFState = FFDestroyable { _ffsHP :: Int } + +data Ammo = PistolBullet | LiquidFuel | Battery | Shell + deriving (Eq,Ord,Enum) + +data SoundOrigin = InventorySound + | BackgroundSound + | OnceSound + | CrSound Int + | CrWeaponSound Int + | WallSound Int + | CrReloadSound Int + | Flamer + | ShellSound Int + | Flame + | LasSound + | FootstepSound Int + | BlockDegradeSound Int + | CrHitSound Int + | BarrelHiss Int + deriving (Eq,Ord,Show) + +type Poly = [Point2] +data PSType = PutCrit Creature + | PutLS LightSource Drawing + | PutButton Button + | PutFlIt FloorItem + | PutPressPlate PressPlate + | PutAutoDoor Point2 Point2 + | PutBlock [Int] Color [Point2] + | PutWindowBlock Point2 Point2 + | PutTriggerDoor Color (World -> Bool) Point2 Point2 + | PutBtDoor Color Point2 Float Point2 Point2 + | PutSwitchDoor Color Point2 Float Point2 Point2 + | RandPS (State StdGen PSType) + | PutNothing + | CollectivePS + { _collectiveID :: Int + , _collectiveNum :: Int + , _collectiveFunction :: [Int] -> State StdGen [PSType] + } + | LabelPS { _psLabel :: Int, _ps :: PSType} + | PutWindow { _pwPoly :: [Point2] + , _pwColor :: Color + } +data PlacementSpot = PS + { _psPos :: Point2 + , _psRot :: Float + , _psType :: PSType + } +data Room = Room + { _rmPolys :: [Poly] + , _rmLinks :: [(Point2,Float)] + , _rmPath :: [(Point2, Point2)] + , _rmPS :: [PlacementSpot] + , _rmBound :: Poly + } + +data SubNode a = SN a | InLink | OutLink + +data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float} + +makeLenses ''RoomLink +makeLenses ''World +makeLenses ''Cloud +makeLenses ''Creature +makeLenses ''CreatureState +makeLenses ''CrSpState +makeLenses ''Goal +makeLenses ''LightSource +makeLenses ''TempLightSource +makeLenses ''Stance +makeLenses ''Carriage +makeLenses ''Posture +makeLenses ''Item +makeLenses ''ItemPos +makeLenses ''ItEffect +makeLenses ''ItAttachment +makeLenses ''ItZoom +makeLenses ''FloorItem +makeLenses ''Particle +makeLenses ''Particle' +makeLenses ''Wall +makeLenses ''Smoke +makeLenses ''ForceField +makeLenses ''FFState +makeLenses ''PressPlate +makeLenses ''Button +makeLenses ''PSType +makeLenses ''PlacementSpot +makeLenses ''Room +makeLenses ''Sound +-- +-- }}} + +numColor :: Int -> Color +numColor 0 = (1,0,0,1) +numColor 1 = (0,1,0,1) +numColor 2 = (0,0,1,1) +numColor 3 = (1,1,0,1) +numColor 4 = (0,1,1,1) +numColor 5 = (1,0,1,1) +numColor 6 = (1,0,0.5,1) +numColor 7 = (0.5,0,1,1) +numColor 8 = (0,0.5,1,1) +numColor 9 = (0,1,0.5,1) +numColor 10 = (0.5,1,0,1) +numColor 11 = (1,0.5,0,1) +numColor 12 = (1,1,1,1) diff --git a/src/Dodge/Debug.hs b/src/Dodge/Debug.hs new file mode 100644 index 000000000..11f66d5a4 --- /dev/null +++ b/src/Dodge/Debug.hs @@ -0,0 +1,50 @@ +module Dodge.Debug where + +import Dodge.Data +import Dodge.Base + +import Geometry.Data +import Picture + +import Control.Lens + + +import qualified Data.IntMap.Strict as IM + +drawCircleAtFor :: Point2 -> Int -> World -> World +drawCircleAtFor p t w = + let n = newParticleKey w + in over particles ( IM.insert n + Particle { _ptPos = p + , _ptStartPos = p + , _ptVel = (0,0) + , _ptPict = onLayer PtLayer $ uncurry translate p $ color white $ circleSolid 20 + , _ptID = n + , _ptUpdate = ptTimer t n + } ) w +drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World +drawCircleAtForCol p t col w = + let n = newParticleKey w + in over particles ( IM.insert n + Particle { _ptPos = p + , _ptStartPos = p + , _ptVel = (0,0) + , _ptPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 20 + , _ptID = n + , _ptUpdate = ptTimer t n + } ) w +drawLineForCol :: [Point2] -> Int -> Color -> World -> World +drawLineForCol ps t col w = + let n = newParticleKey w + in over particles ( IM.insert n + Particle { _ptPos = head ps + , _ptStartPos = head ps + , _ptVel = (0,0) + , _ptPict = onLayer PtLayer $ color col $ lineOfThickness 5 ps + , _ptID = n + , _ptUpdate = ptTimer t n + } ) w + +ptTimer :: Int -> Int -> World -> World +ptTimer 0 i = over particles (IM.delete i) +ptTimer time i = set (particles . ix i . ptUpdate) $ ptTimer (time - 1) i diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs new file mode 100644 index 000000000..fc823cfd6 --- /dev/null +++ b/src/Dodge/Initialisation.hs @@ -0,0 +1,68 @@ +module Dodge.Initialisation where +-- imports {{{ +import Dodge.Prototypes +import Dodge.Data +import Dodge.Critters +import Dodge.Base + +import Data.List +import Data.Char +import Data.Maybe +import Data.Function +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.PatriciaTree +import Codec.BMP +import qualified Data.ByteString as B +import Control.Lens +import Control.Applicative +import Control.Monad.State +import Control.Monad +import System.Random +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import qualified Data.Map as M + +--import Graphics.Gloss +--import Graphics.Gloss.Interface.IO.Game +--import Graphics.Gloss.Geometry.Angle +--import Graphics.Gloss.Geometry.Line +--import qualified Graphics.Gloss.Data.Point.Arithmetic as PA +--import Graphics.Gloss.Data.Vector +--import Graphics.Gloss.Data.Point +import Foreign.ForeignPtr +import Control.Concurrent +import Data.Tree + +initializeWorld :: World -> World +initializeWorld w = w + +initialWorld = basicWorld + { _keys = S.empty + , _cameraPos = (0,0) + , _cameraRot = 0 + , _cameraZoom = 1 + , _creatures = IM.fromList [(0,startCr)] + , _particles = IM.empty + , _walls = IM.empty + , _forceFields = IM.empty + , _floorItems = IM.empty + , _randGen = mkStdGen 2 + , _mousePos = (0,0) + , _testString = [] + , _yourID = 0 + , _worldEvents = id + , _pressPlates = IM.empty + , _buttons = IM.empty + , _soundQueue = [] +-- , _loadedSounds = IM.empty + , _sounds = M.empty + , _decorations = IM.empty + , _unlimitedAmmo = True + , _storedLevel = Nothing + , _menuState = LevelMenu 1 + , _worldState = M.empty + , _windowX = 800 + , _windowY = 840 + } + + diff --git a/src/Dodge/KeyEvents.hs b/src/Dodge/KeyEvents.hs new file mode 100644 index 000000000..eef50e7db --- /dev/null +++ b/src/Dodge/KeyEvents.hs @@ -0,0 +1,190 @@ +module Dodge.KeyEvents where +-- imports {{{ +import Dodge.Data +import Dodge.Base +import Dodge.CreatureActions +import Dodge.SoundLogic + +import Geometry + +import Control.Lens + +import Data.Maybe +import Data.Char +import Data.List +import Data.Function + +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM + +import SDL + +--import Graphics.Gloss +--import Graphics.Gloss.Interface.IO.Game + +-- }}} + +pauseGame :: World -> World +pauseGame w = w {_menuState = PauseMenu} + +handleEvent :: World -> Event -> Maybe World +handleEvent w e = case eventPayload e of + KeyboardEvent kev -> handleKeyEvent w kev + MouseMotionEvent mmev -> handleMouseMotionEvent w mmev + MouseButtonEvent mbev -> handleMouseButtonEvent w mbev + MouseWheelEvent mwev -> handleMouseWheelEvent w mwev + WindowSizeChangedEvent sev -> handleResizeEvent w sev + _ -> Just w + +handleKeyEvent :: World -> KeyboardEventData -> Maybe World +handleKeyEvent w kev = case keyboardEventKeyMotion kev of + Released -> Just $ over keys (S.delete $ getKeycode kev) w + _ -> handlePressedKeyEvent (addKey (getKeycode kev) w) (keyboardEventRepeat kev) (getKeycode kev) + where getKeycode :: KeyboardEventData -> Keycode + getKeycode = keysymKeycode . keyboardEventKeysym + +addKey :: Keycode -> World -> World +addKey k = over keys $ S.insert k + +handlePressedKeyEvent :: World -> Bool -> Keycode -> Maybe World +handlePressedKeyEvent w True _ = Just w +handlePressedKeyEvent w _ keycode + = case keycode of + KeycodeEscape -> Nothing +-- KeycodeEscape -> Just $ pauseGame $ escapeMap w + KeycodeC -> Just $ pauseGame $ escapeMap w + KeycodeF -> Just $ dropItem w + KeycodeM -> Just $ toggleMap w + KeycodeP -> Just $ pauseGame $ escapeMap w + KeycodeR -> Just $ fromMaybe w $ reloadWeapon (_yourID w) w + KeycodeT -> Just $ testEvent w + KeycodeSpace -> Just $ spaceAction w + KeycodeQ -> Just $ w {_cameraRot = _cameraRot w + 0.01} + KeycodeE -> Just $ w {_cameraRot = _cameraRot w - 0.01} + _ -> Just w + +handleMouseMotionEvent :: World -> MouseMotionEventData -> Maybe World +handleMouseMotionEvent w mmev + = Just $ set mousePos (fromIntegral x - 0.5*_windowX w + ,0.5*_windowY w - fromIntegral y + ) w + where P (V2 x y) = mouseMotionEventPos mmev + +handleMouseButtonEvent :: World -> MouseButtonEventData -> Maybe World +handleMouseButtonEvent w mbev = case mouseButtonEventMotion mbev of + Released -> Just $ over mouseButtons (S.delete but) w + Pressed -> handlePressedMouseButton but $ over mouseButtons (S.insert but) w + where but = mouseButtonEventButton mbev + +handlePressedMouseButton :: MouseButton -> World -> Maybe World +handlePressedMouseButton ButtonMiddle w = Just $ set lbClickMousePos (_mousePos w) w +handlePressedMouseButton _ w = Just w + +handleMouseWheelEvent :: World -> MouseWheelEventData -> Maybe World +handleMouseWheelEvent w mwev = + case mouseWheelEventPos mwev of + V2 x y | y > 0 -> Just $ wheelUpEvent w + | y < 0 -> Just $ wheelDownEvent w + | otherwise -> Just $ w +-- case mouseWheelEventDirection mwev of +-- ScrollNormal -> Just $ wheelUpEvent w +-- ScrollFlipped -> Just $ wheelDownEvent w + + +handleResizeEvent :: World -> WindowSizeChangedEventData -> Maybe World +handleResizeEvent w sev = Just $ set windowX (fromIntegral x) + $ set windowY (fromIntegral y) w + where V2 x y = windowSizeChangedEventSize sev + +toggleMap w = w & mapDisplay . _1 %~ not +escapeMap w = w & mapDisplay . _1 .~ False + +wheelUpEvent :: World -> World +wheelUpEvent w + = case _mapDisplay w of + (True,z) -> w & mapDisplay . _2 .~ min 0.3 (z+(0.1*z)) + _ | rbPressed -> fromMaybe w $ (yourItem w ^? itScrollUp) <*> pure (_crInvSel (you w)) + <*> pure w + | lbPressed -> w {_cameraZoom = _cameraZoom w + 0.1} + | otherwise -> upInvPos w + where lbPressed = ButtonLeft `S.member` mbs + rbPressed = ButtonRight `S.member` mbs + mbs = _mouseButtons w +wheelDownEvent :: World -> World +wheelDownEvent w + = case _mapDisplay w of + (True,z) -> w & mapDisplay . _2 .~ max 0.05 (z-(0.1*z)) + _ | rbPressed -> fromMaybe w $ (yourItem w ^? itScrollDown) <*> pure (_crInvSel (you w)) + <*> pure w + | lbPressed -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01} + | otherwise -> downInvPos w + where lbPressed = ButtonLeft `S.member` mbs + rbPressed = ButtonRight `S.member` mbs + mbs = _mouseButtons w + +upInvPos :: World -> World +--upInvPos w = soundOnce 3 $ stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w +upInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w + where is = IM.keys $ _crInv $ _creatures w IM.! _yourID w + isis = is ++ is + x = before (_crInvSel (you w)) isis +downInvPos :: World -> World +--downInvPos w = playSoundFromFor InventorySound 3 2 $ stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w +downInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w + where is = IM.keys $ _crInv $ _creatures w IM.! _yourID w + isis = is ++ is + x = after (_crInvSel (you w)) isis + + +-- these are incomplete: should put in error case here! +before y (x:z:ys) | y == z = x + | otherwise = before y (z:ys) +after y (x:z:ys) | y == x = z + | otherwise = after y (z:ys) + +mouseActionsCr :: S.Set MouseButton -> Creature -> Creature +mouseActionsCr keys cr + | rbPressed + = set ( crState . stance . posture) Aiming cr + | otherwise + = set ( crState . stance . posture) AtEase cr + where lbPressed = ButtonLeft `S.member` keys + rbPressed = ButtonRight `S.member` keys +-- wUp = MouseButton WheelUp `S.member` keys +-- -- wUp = Char 'q' `S.member` keys +-- wDown = MouseButton WheelDown `S.member` keys + +mouseActionsWorld :: S.Set MouseButton -> World -> World +mouseActionsWorld keys w + | lbPressed && rbPressed + = useItemContinuous (_yourID w) w + | mbPressed + = set lbClickMousePos (_mousePos w) $ over cameraRot (\r-> r - rotation) w + | otherwise + = w + where lbPressed = ButtonLeft `S.member` keys + rbPressed = ButtonRight `S.member` keys + mbPressed = ButtonMiddle `S.member` keys + ---wUp = MouseButton WheelUp `S.member` keys + ---wDown = MouseButton WheelDown `S.member` keys + ---theItem = _crInv (you w) IM.! _crInvSel (you w) + rotation = angleBetween (_mousePos w) (_lbClickMousePos w) + +-- for now, left are floor items, right are buttons +closestActiveObject :: World -> Maybe (Either FloorItem Button) +closestActiveObject w = listToMaybe $ sortBy (compare `on` dist ypos . pos) $ actObjs + where ypos = _crPos $ you w + actObjs = filter (\obj -> dist ypos (pos obj) < 40 && hasLOS ypos (pos obj) w) + $ map Left (IM.elems $ _floorItems w) ++ map Right (IM.elems $ _buttons w) + pos (Right x) = _btPos x + pos (Left x) = _flItPos x + +spaceAction :: World -> World +spaceAction w = case closestActiveObject w of + Just (Left flit) -> pickUpItem' flit w + Just (Right but) -> _btEvent but but w + Nothing -> w + +testEvent :: World -> World +testEvent w = w + diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs new file mode 100644 index 000000000..4aa6a3dc6 --- /dev/null +++ b/src/Dodge/Layout.hs @@ -0,0 +1,187 @@ +module Dodge.Layout where +-- imports {{{ +import Dodge.Data +import Dodge.Weapons +import Dodge.Critters +import Dodge.LevelGen +import Dodge.Base +import Dodge.RandomHelp +import Dodge.Prototypes +import Dodge.Path + +import Geometry +-- +--import Graphics.Gloss +--import Graphics.Gloss.Data.Vector +--import Graphics.Gloss.Geometry.Line +--import Graphics.Gloss.Geometry.Angle +-- +import Control.Monad.State +--import Control.Monad.Loops +import Control.Lens +import System.Random + +import Data.List +import Data.Maybe +import Data.Tree +import Data.Either +import Data.Function +import qualified Data.Map as M + +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.Basic +import Data.Graph.Inductive.PatriciaTree +import Data.Graph.Inductive.NodeMap + +import qualified Data.IntMap.Strict as IM +-- }}} + +generateFromTree :: State StdGen (Tree Room) -> World -> World +generateFromTree t w = zoning $ placeSpots plmnts + $ w {_walls = wallsFromTree tr, _randGen = g +-- ,_loadedSounds = lSounds + ,_pathGraph = path + ,_pathGraph' = pairGraph + ,_pathPoints = foldr insertPoint IM.empty (labNodes path) + ,_pathInc = pinc} + where tr = evalState t $ _randGen w + plmnts = concatMap _rmPS $ flatten tr + g = _randGen w +-- lSounds = _loadedSounds w + path = pairsToGraph dist pairGraph + pairGraph = makePath tr + insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] + pinc = M.fromList $ pairsToIncidence pairGraph + zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) + w + wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize + = insertIMInZone x y wlid wl + | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips + where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1)) + wlid = _wlID wl + ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1) + +makePath :: Tree Room -> [(Point2,Point2)] +makePath = concat . map _rmPath . flatten + +wallsFromTree :: Tree Room -> IM.IntMap Wall +wallsFromTree t = divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t) + +divideWall :: Wall -> [Wall] +divideWall wl + = let (a:b:_) = _wlLine wl + --ps = divideLine (zoneSize * 2) a b + ps = divideLine (zoneSize * 2) a b + in map (\(x,y) -> wl {_wlLine = [x,y]}) $ zip (init ps) (tail ps) + +divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall +divideWallIn wl wls = + let (wl':newWls) = divideWall wl + k = newKey wls + newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls + in foldr (\w -> IM.insert (_wlID w) w) wls (wl':newWls') + +divideWalls :: IM.IntMap Wall -> IM.IntMap Wall +divideWalls wls = IM.foldr divideWallIn wls wls + +collapseTree :: Tree (Tree (Either Room Room)) -> Tree (Either Room Room) +collapseTree = g . expandTreeBy f + where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs + f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs + g (Node (Right x) []) = Node (Right x) [] + g (Node (Right x) xs) = Node (Left x) $ map g xs + g (Node y ys) = Node y $ map g ys + + +insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a) +insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj + where f _ = IM.insert y obj + +allPairs :: Eq a => [a] -> [(a,a)] +allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y] + +treePost :: [a] -> a -> Tree a +treePost [] y = Node y [] +treePost (x:xs) y = Node x [treePost xs y] + +randomiseLinks :: RandomGen g => Room -> State g (Tree (Either Room Room)) +randomiseLinks r = do + newLinks <- shuffle $ init $ _rmLinks r + return $ connectRoom $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]} +randLinks :: RandomGen g => Room -> State g Room +randLinks r = do + newLinks <- shuffle $ init $ _rmLinks r + return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]} + +filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room +filterLinks cond r = do + newLinks <- shuffle $ filter cond $ init $ _rmLinks r + return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]} + +changeLinkTo :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room +changeLinkTo cond r = do + l <- takeOne $ filter cond $ _rmLinks r + let newLinks = delete l (_rmLinks r) ++ [l] + return $ r {_rmLinks = newLinks} + + +-- Left elements get new children, Right elements inherit the children from the +-- mapped over node +composeTreeWith :: (a -> Tree (Either b b)) -> Tree a -> Tree (Either b b) +composeTreeWith f (Node x []) = f x +composeTreeWith f (Node x xs) = paste xs $ f x + where paste xs (Node (Right y) _) = Node (Left y) (map (composeTreeWith f) xs) + paste xs (Node (Left y) ys) = Node (Left y) (map (paste xs) ys) + +doPolysIntersect :: [Point2] -> [Point2] -> Bool +doPolysIntersect (p:ps) (q:qs) + = any isJust $ (\(a,b) (c,d) -> intersectSegSeg' a b c d) <$> pair1s <*> pair2s + where pair1s = zip (p:ps) (ps++[p]) + pair2s = zip (q:qs) (qs++[q]) +doPolysIntersect [] _ = False +doPolysIntersect _ [] = False + +boundClip :: Tree Room -> Bool +boundClip t = or $ map (uncurry doPolysIntersect) [(x,y) | x<- xs, y<-xs, x>y] + ++ map f [(ps,qs) | ps <- xs, qs <-xs, ps/=qs] + where xs = map _rmBound $ flatten t + f ([],qs) = False + f ((p:_),qs) = pointInPolygon p qs + +noBoundClip :: Tree Room -> Bool +noBoundClip = not . boundClip + +connectRoom :: a -> Tree (Either a a) +connectRoom r = Node (Right r) [] +deadRoom :: a -> Tree (Either a a) +deadRoom r = Node (Left r) [] + +onRoot :: (a -> a) -> Tree a -> Tree a +onRoot f (Node t ts) = Node (f t) ts + +shiftRoomTree :: Tree Room -> Tree Room +shiftRoomTree (Node t []) = Node t [] +shiftRoomTree (Node t ts) = Node t $ zipWith (\l -> shiftRoomTree . onRoot (shiftRoomBy l . f)) + (_rmLinks t) + ts + where f r = shiftRoomBy ((0,0) -.- (rotateV (pi-a) p),0) $ shiftRoomBy ((0,0),pi-a) r + where (p,a) = last $ _rmLinks r + +shiftRoomBy :: (Point2,Float) -> Room -> Room +shiftRoomBy shift@(pos,rot) r = + over rmPolys (fmap (map (shiftPointBy shift))) + $ over rmLinks (fmap (shiftLinkBy shift)) + $ over rmPath (map (shiftPathPointBy shift)) + $ over rmPS (fmap (shiftPSBy shift)) + $ over rmBound (map (shiftPointBy shift)) + r + +shiftPathPointBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2) + +shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot) +shiftPSBy (pos,rot) ps = case ps of + PS {} -> over psPos (shiftPointBy (pos,rot)) + $ over psRot (+rot) + ps + + diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs new file mode 100644 index 000000000..602f8d7f0 --- /dev/null +++ b/src/Dodge/LevelGen.hs @@ -0,0 +1,756 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +module Dodge.LevelGen where +-- imports {{{ +import Dodge.Data +import Dodge.Base +import Dodge.SoundLogic +import Dodge.Prototypes +import Dodge.Block + +import Geometry +import Picture + +import System.Random +--import Graphics.Gloss +--import Graphics.Gloss.Geometry.Line +--import Graphics.Gloss.Geometry.Angle +--import Graphics.Gloss.Data.Vector +import Control.Monad.State +import Data.List +import Data.Function +import Control.Applicative +import Control.Lens +import Data.Maybe +import qualified Data.IntMap.Strict as IM +import qualified Data.Set as S +import qualified Data.Map as M + +import Data.Graph.Inductive +import Data.Graph.Inductive.NodeMap +import Data.Tree +-- }}} + +inSegSeg p1 p2 a1 a2 = myIntersectSegSeg p1' p2' a1' a2' + where p1' = p1 +.+ normalizeV (p1 -.- p2) + p2' = p2 +.+ normalizeV (p2 -.- p1) + a1' = a1 +.+ normalizeV (a1 -.- a2) + a2' = a2 +.+ normalizeV (a2 -.- a1) + +-- + + +--supposes that the quadrilateral points are given in anticlockwise order +-- cutOutQuad :: Point -> Point -> Point -> Point -> IM.IntMap Wall -> IM.IntMap Wall +-- cutOutQuad p1 p2 p3 p4 walls = cutLine p4 p1 . cutLine p3 p4 . cutLine p2 p3 . cutLine p1 p2 $ walls + +collidePointAllWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall +collidePointAllWalls p1 p2 walls = IM.filter f walls + where f wall + = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) + of Nothing -> False + _ -> True + +-- returns walls that collide with lines, and the point of collision + +collidePointAllWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,Point2) +collidePointAllWallsPoints p1 p2 walls = IM.mapMaybe f walls + where f wall + = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) + of Nothing -> Nothing + Just p -> Just (wall,p) + +collidePointAllWallsPoints' :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,[Point2]) +collidePointAllWallsPoints' p1 p2 walls = IM.mapMaybe f walls + where f wall + = case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1) + of Nothing -> Nothing + Just p -> Just (wall,[p]) + +collidePolygonWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap (Wall,[Point2]) +collidePolygonWalls (p:ps) walls + = IM.unionsWith f (fmap g (zip (p:ps) (ps ++ [p]))) + -- = fmap ($ walls) $ zipWith collidePointAllWallsPoints' (init ps) (tail ps) + --where f (x,xs) (_,ys) = (x,xs++ys) + where f (x,xs) (_,ys) = (x,xs++ys) + g (p1,p2) = collidePointAllWallsPoints' p1 p2 walls + +-- -- assumes that walls meet in corners +-- there appears to be an issue when one wall point is inside and the other exactly on the polygon +-- this is probably an issue with collidePolygonwalls +existingWallChanges :: [Point2] -> (Wall,[Point2]) -> [Wall] +existingWallChanges poly (wall,ps) = catMaybes [w1,w2] + where wp1 = _wlLine wall !! 0 + wp2 = _wlLine wall !! 1 + c1 = head $ sortBy (compare `on` dist wp1) ps + c2 = head $ sortBy (compare `on` dist wp2) ps + --c1 = last ps + --c2 = last ps + w1 = if errorPointInPolygon 5 wp1 poly || wp1 == c1 + then Nothing + else Just $ wall {_wlLine = [ wp1, c1 ] } + w2 = if errorPointInPolygon 6 wp2 poly || wp2 == c2 + then Nothing + else Just $ wall {_wlLine = [ c2, wp2 ] } + + +removeWallsInPolygon :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall +removeWallsInPolygon ps walls = IM.filter (not . cond) walls +-- where cond wall = pointInsidePolygon (_wlLine wall !! 0) ps +-- && pointInsidePolygon (_wlLine wall !! 1) ps + where cond wall = pointInsidePolygon (_wlLine wall !! 0) ps + && pointInsidePolygon (_wlLine wall !! 1) ps + +pointInsidePolygon :: Point2 -> [Point2] -> Bool +pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs + || any (\l -> uncurry isOnLine l p) pairs + where pairs = zip (x:xs) (xs ++ [x]) + s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs))) + -.- p + + +-- ok, now to find out which new walls need to be drawn +drawCutWall :: (Point2, Point2) -> IM.IntMap Wall -> IM.IntMap Wall +drawCutWall (p1,p2) walls = + case maybeW of Just w -> if errorIsLHS 200 (_wlLine w !! 0) (_wlLine w !! 1) p3 + then walls + else IM.insert k newWall walls + Nothing -> IM.insert k newWall walls + where p3 = 0.5 *.* (p1 +.+ p2) + p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1) + maybeW = wallOnLine p3 p4 walls + k = case IM.lookupMax walls + of Nothing -> 0 + Just (j,_) -> j + 1 + newWall = basicWall {_wlLine = [p1,p2], _wlID = k} + + +drawCutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall +drawCutWalls (q:qs) walls = foldr drawCutWall walls (zip (q:qs) (qs++[q])) +-- where (q:qs) = reverse $ orderPolygon +-- -- $ intersectPolygonWalls ps walls +-- $ maybeToList $ intersectSegSeg (20,0) (100,900) (-200,400) (200,400) +-- -- $ (++) ps $ nub $ concat $ IM.elems $ fmap snd $ collidePolygonWalls ps walls + +-- I have no idea why collidePolygonWalls is sometimes dropping an intersection +-- point between the walls and the polygon +-- Trying a workaround +intersectPolygonWalls :: [Point2] -> IM.IntMap Wall -> [Point2] +intersectPolygonWalls ps walls = nub $ concat $ IM.elems $ IM.map (intersectSegsWall ps) walls +--intersectPolygonWalls (p:ps) walls = nub $ concat [intersectSegWalls s1 s2 walls | (s1,s2) <- segs] +-- where segs = zip (p:ps) (ps ++ [p]) + +intersectSegWalls s1 s2 ws = concatMap (intersectSegWall s1 s2) $ IM.elems ws + +intersectSegsWall (p:ps) wall = concat [intersectSegWall s1 s2 wall | (s1,s2) <- zip (p:ps) (ps++[p])] + +-- finds intersection, or any segment points contained in the wall +intersectSegWall s1 s2 w = catMaybes [myIntersectSegSeg s1 s2 w1 w2 +-- ,intersectSegPoint w1 w2 s1 +-- ,intersectSegPoint w1 w2 s2 + ] + where w1 = _wlLine w !! 0 + w2 = _wlLine w !! 1 + +intersectSegPoint s1 s2 p = if isOnLine s1 s2 p then Just p else Nothing + +-- new procedure: line by line +-- then remove all walls inside the polygon + +-- abuses the list nature of wlLine +cutWall1 :: Point2 -> Point2 -> Wall -> Wall +cutWall1 p1 p2 wall = case maybeCP of + Nothing -> wall + Just cp -> wall {_wlLine = [cp,w0,w1]} + where wl = _wlLine wall + w0 = wl !! 0 + w1 = wl !! 1 + w0' = w0 +.+ normalizeV (w0 -.- w1) + w1' = w1 +.+ normalizeV (w1 -.- w0) + p1' = p1 +.+ normalizeV (p1 -.- p2) + p2' = p2 +.+ normalizeV (p2 -.- p1) + pT = p1' +.+ vNormal (normalizeV (p1 -.- p2)) + pB = p1' -.- vNormal (normalizeV (p1 -.- p2)) + --maybeCP = intersectSegSeg p1' p2' w0' w1'-- <|> intersectSegSeg w0 w1 pT pB + --maybeCP = inSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB + maybeCP = inSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB + --maybeCP = intersectSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB +cutWalls1 :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall +cutWalls1 p1 p2 ws = foldr splitAndAdd ws $ IM.map (cutWall1 p1 p2) ws + where splitAndAdd w ws + = case _wlLine w of + (cp:w0:w1:[]) -> IM.insert (newKey ws) (w {_wlLine = [cp,w1] + ,_wlID = newKey ws}) + $ IM.insert (_wlID w) (w {_wlLine = [w0,cp]}) ws + (x:y:[]) -> ws + +cutWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> [Point2] +cutWallsPoints p1 p2 ws = map head $ filter (\xs -> length xs > 2) + $ IM.elems $ IM.map (_wlLine . cutWall1 p1 p2) ws + +cutWallsProcess :: [Point2] -> IM.IntMap Wall -> ([Point2], IM.IntMap Wall) +cutWallsProcess (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p])) + where f (p1,p2) (as,ws') = (as ++ cutWallsPoints p1 p2 ws', cutWalls1 p1 p2 ws') + +cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall +cutWalls qs walls = -- IM.filter (not . wallIsZeroLength) $ fuseWalls $ + drawCutWalls rs $ IM.filter (not.wallIsZeroLength) + $ removeWallsInPolygon ps -- cwals + (fuseWallsWith zs cwals) + where (zs,cwals) = cutWallsProcess ps walls + ps = orderPolygon qs + --ps = orderPolygon $ map perturbToWallPoints qs + rs = orderPolygon $ nub $ zs ++ qs +-- perturbToWallPoints p = fromMaybe p $ find (\p1 -> dist p p1 < 1) wps + + +fusePoint :: [Point2] -> Point2 -> Maybe Point2 +fusePoint ps p = find (\q -> dist p q < 5) ps + +pointIfNotClose :: [Point2] -> Point2 -> Maybe Point2 +pointIfNotClose ps p = case fusePoint ps p of + Nothing -> Just p + _ -> Nothing + +fuseWall :: ([Point2], Wall) -> ([Point2], Wall) +fuseWall (ps, w) = (qs, w {_wlLine = newLine}) + where wp0 = _wlLine w !! 0 + wp0' = fromMaybe wp0 $ fusePoint ps wp0 + ps0 = maybeToList (pointIfNotClose ps wp0) ++ ps + wp1 = _wlLine w !! 1 + wp1' = fromMaybe wp1 $ fusePoint ps0 wp1 + newLine = [wp0',wp1'] + qs = catMaybes [pointIfNotClose ps wp0, pointIfNotClose ps0 wp1] ++ ps + +fuseWalls :: IM.IntMap Wall -> IM.IntMap Wall +fuseWalls ws = snd $ IM.foldr fuseWalls' ([], IM.empty) ws + where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w) + in (qs, IM.insert (_wlID w') w' ws) +fuseWallsWith :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall +fuseWallsWith zs ws = snd $ IM.foldr fuseWalls' (zs, IM.empty) ws + where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w) + in (qs, IM.insert (_wlID w') w' ws) + +wallIsZeroLength w = l !! 0 == l !! 1 + where l = _wlLine w + +treeTrunk :: [a] -> Tree a -> Tree a +treeTrunk [] t = t +treeTrunk (x:xs) t = Node x [treeTrunk xs t] + +applyToRoot :: (a -> a) -> Tree a -> Tree a +applyToRoot f (Node x xs) = Node (f x) xs + +placeSpots :: [PlacementSpot] -> World -> World +placeSpots pss w = foldr placeSpot w basicPlacements + where (collectivePlacements,basicPlacements) = partition typeIsCollective pss + typeIsCollective (ps@PS {}) = case _psType ps of CollectivePS {} -> True + _ -> False + typeIsCollective _ = False + + groupedPlacements = groupBy ((==) `on` _collectiveID . _psType) + $ sortBy (compare `on` _collectiveID . _psType) collectivePlacements + +placeSpot :: PlacementSpot -> World -> World +placeSpot ps w = case ps of + PS {_psPos = p, _psRot = rot, _psType = PutButton bt} + -> placeBt bt p rot w + PS {_psPos = p, _psRot = rot, _psType = PutFlIt fi} + -> placeFlIt fi p rot w + PS {_psPos = p, _psRot = rot, _psType = PutCrit cr} + -> placeCr cr p rot w + PS {_psPos = p, _psRot = rot, _psType = PutLS ls dec} + -> placeLS ls dec p rot w + PS {_psPos = p, _psRot = rot, _psType = PutPressPlate pp} + -> placePressPlate pp p rot w + PS {_psType = RandPS rgen} + -> placeSpot (set psType evaluatedType ps) (set randGen g w) + where (evaluatedType, g) = runState rgen (_randGen w) + + PS {_psPos = p, _psRot = rot, _psType = PutTriggerDoor col f a b} + -> addTriggerDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w + + PS {_psPos = p, _psRot = rot, _psType = PutAutoDoor a b} + -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w + + PS {_psPos = p, _psRot = rot, _psType = PutBlock (hp:hps) col ps} + -> putBlock (map (shiftPointBy (p,rot)) ps) hp col False hps w + + PS {_psPos = p, _psRot = rot, _psType = PutBtDoor c bp f a b} + -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) + (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w + PS {_psPos = p, _psRot = rot, _psType = PutSwitchDoor c bp f a b} + -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot) + (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w + + PS {_psPos = p, _psRot = rot, _psType = PutWindowBlock a b} + -> putWindowBlock (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w + + PS {_psPos = p, _psRot = rot, _psType = PutWindow { _pwPoly = ps, _pwColor = c }} + -> rmCrossPaths $ over walls (addWindow (q:qs) c) w + where (q:qs) = translateS p $ rotateS rot ps + rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q]) + + _ -> w + +class Shiftable a where + translateS :: Point2 -> a -> a + rotateS :: Float -> a -> a + +instance {-# OVERLAPPING #-} Shiftable Point2 where + translateS = (+.+) + rotateS = rotateV + +instance (Shiftable a,Shiftable b) => Shiftable (a, b) where + translateS p (x,y) = (translateS p x,translateS p y) + rotateS r (x,y) = ( rotateS r x, rotateS r y) + +instance (Shiftable a) => Shiftable [a] where + translateS p x = map (translateS p) x + rotateS r x = map (rotateS r) x + +instance Shiftable RoomLink where + translateS q (RL p r) = RL (p +.+ q) r + rotateS s (RL p r) = RL (rotateV s p) (r+s) + +instance Shiftable PlacementSpot where + translateS p' (PS p r x) = PS (p +.+ p') r x + rotateS r' (PS p r x) = PS (rotateV r' p) (r + r') x + +pairsToGraph :: (Ord a, Eq a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b +pairsToGraph f pairs = let nodes = nub (map fst pairs ++ map snd pairs) + pairs' = map (\(x,y)->(x,y,f x y)) pairs + in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes >> insMapEdgesM pairs' + +makeButton :: Color -> (World -> World) -> Button +makeButton c eff = Button + { _btPict = onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10) + , _btPos = (0,0) + , _btRot = 0 + , _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b)) +-- . set (buttons . ix (_btID b) . btPict) +-- (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10)) +-- . set (buttons . ix (_btID b) . btState) BtNoLabel +-- . set (buttons . ix (_btID b) . btEvent) (\b -> return) + . soundOnce 1 $ w + , _btID = 0 + , _btText = "Button" + --, _btText = "Button" + , _btState = BtOff + } + where + turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)} + onPict = (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10)) + +makeSwitch :: Color -> (World -> World) -> (World -> World) -> Button +makeSwitch c effOn effOff = Button + { _btPict = offPict + , _btPos = (0,0) + , _btRot = 0 + , _btEvent = flipSwitch + , _btID = 0 + , _btText = "Switch" + , _btState = BtOff + } + where + flipSwitch b w = switchEffect b . soundOnce 1 $ w + switchEffect b = case _btState b of + BtOff -> effOn . over buttons (IM.adjust turnOn (_btID b)) + BtOn -> effOff . over buttons (IM.adjust turnOff (_btID b)) + offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5 + polygon $ rectNSEW (-2) (-5) (-10) (10) + ,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)] + ] + onPict = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5 + polygon $ rectNSEW (-2) (-5) (-10) (10) + ,polygon [(-2,-5), (6,4),( 10,4),(2,-5)] + ] + turnOn :: Button -> Button + turnOn bt = bt {_btState = BtOn, _btPict = onPict} + turnOff :: Button -> Button + turnOff bt = bt {_btState = BtOff, _btPict = offPict} + + + +-- probably don't have to rebuild the entire graph, oh well +addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World +addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt) + $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) + $ set pathGraph newGraph + $ set pathGraph' newGraphPairs + $ addTriggerDoor c cond a b w + where bid = newKey $ _buttons w + cond w = BtNoLabel == (_btState $ _buttons w IM.! bid) + bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid} + (newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b)) + $ _pathGraph' w + newGraph = pairsToGraph dist newGraphPairs + insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] + eff w' = over pathGraph' (removedPairs ++) + . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w' + f (x,y) = (x,y,dist x y) + +addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World +addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt) + $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) + $ set pathGraph newGraph + $ set pathGraph' newGraphPairs + $ addTriggerDoor c cond a b w + where bid = newKey $ _buttons w + cond w = BtOn == (_btState $ _buttons w IM.! bid) + bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid} + (newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b)) + $ _pathGraph' w + newGraph = pairsToGraph dist newGraphPairs + insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] + openDoor w' = over pathGraph' (removedPairs ++) + . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w' + f (x,y) = (x,y,dist x y) + closeDoor w' = over pathGraph' (\pg -> pg \\ removedPairs) + . over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w' + +addTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World +addTriggerDoor c cond a b = over walls (triggerDoor c cond a b) + +triggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall +triggerDoor c cond a b wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond a b is + where i = newKey wls + is = [i..] + +mkTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall] +mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond) + xs + [ [pld,hwd] + , [hwd,hwu] + , [hwu,plu] + , [plu,pld] + , [pru,hwu] + , [hwu,hwd] + , [hwd,prd] + , [prd,pru] + ] + [ [plld,pld] + , [pld,plu] + , [plu,pllu] + , [pllu,plld] + , [prru,pru] + , [pru,prd] + , [prd,prrd] + , [prrd,prru] + ] + where norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl)) + hw = 0.5 *.* (pl +.+ pr) + perp = 20 *.* normalizeV (pl -.- pr) + --perp = pl -.- hw + plu = pl +.+ norm + pld = pl -.- norm + pru = pr +.+ norm + prd = pr -.- norm + hwu = hw +.+ norm + hwd = hw -.- norm + pllu = plu +.+ perp + plld = pld +.+ perp + prru = pru -.- perp + prrd = prd -.- perp + addSound (x:xs) = f x : xs + f wl = over doorMech g wl + g dm w | dist wp pld > 2 && dist wp hwd > 2 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 + $ dm w + | otherwise = dm w + where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1 + +triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall +triggerDoorPane c cond n [a,b] [a',b'] = Door + { _wlLine = [a,b] + , _wlID = n + , _doorMech = dm + , _wlColor = c + , _wlDraw = Nothing + , _wlSeen = False + , _wlIsSeeThrough = False +-- , _doorLine = [a,b,a',b'] + } + where + dm w | cond w = flip (foldr changeZonedWall) zoneps + $ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a') + | otherwise = flip (foldr changeZonedWall') zoneps + $ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a) + zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b] + | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b + openDoor :: Wall -> Wall + openDoor wl = case _wlLine wl of + ((!pa):(!pb):_) -> wl {_wlLine = [mvPointToward a' pa, mvPointToward b' pb]} + closeDoor :: Wall -> Wall + closeDoor wl = case _wlLine wl of + ((!pa):(!pb):_) -> wl {_wlLine = [mvPointToward a pa, mvPointToward b pb]} + changeZonedWall (!x,!y) + = over wallsZone $ adjustIMZone openDoor x y n + changeZonedWall' (!x,!y) + = over wallsZone $ adjustIMZone closeDoor x y n + +addAutoDoor :: Point2 -> Point2 -> World -> World +addAutoDoor a b = over walls (autoDoorAt a b) + +removePathsCrossing :: Point2 -> Point2 -> World -> World +removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg' + $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) + w + where pg' = filter (not . isJust . uncurry (intersectSegSeg' a b)) $ _pathGraph' w + insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] + newGraph = pairsToGraph dist pg' + +putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World +putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs + where pairs = zip (p:ps) (ps ++ [p]) + wWithBlock = addBlock (p:ps) i c b is w + +putWindowBlock :: Point2 -> Point2 -> World -> World +--putWindowBlock a b w = foldr makeBlockAt w $ zip ps ns +putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns + where d = dist a b + rot = argV (b -.- a) + numPoints' = floor (d / 20) + numPoints = numPoints'*2 + ns = take (numPoints+1) [0..] + ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a)) + $ map fromIntegral ns + k = newKey $ _walls w + ksAtN i = [k+i*4,k+i*4 + 1 ,k+i*4 +2, k+i*4+3] + bSide = d / (fromIntegral numPoints) + ds = [(-bSide,-10),(-bSide,10),(bSide,10),(bSide,-10)] + polyAtP p = map ((+.+) p . rotateV rot) ds + hp = 1 + degradeHP = [5,5] + winCol = withAlpha 0.5 cyan + makeBlockAt :: (Point2,Int) -> World -> World + makeBlockAt (p,i) w = + let (k0:k1:k2:k3:_) = ksAtN i + (bl:tl:tr:br:_) = polyAtP p + shadows | i == 0 = ksAtN 1 + | i == numPoints - 1 = ksAtN $ numPoints - 2 + | otherwise = ksAtN (i-1) ++ ksAtN (i+1) + seen | even i = True + | otherwise = False + isLeftmost | i == 0 = True + | otherwise = False + isRightmost | i == numPoints = True + | otherwise = False + l = Block + { _wlLine = [bl,tl] + , _wlID = k0 + , _wlColor = winCol + , _wlDraw = Nothing + , _wlSeen = False + , _blIDs = ksAtN i + , _blHP = hp + , _wlIsSeeThrough = True + --, _blVisible = False + , _blVisible = isLeftmost + , _blShadows = shadows + , _blDegrades = degradeHP + } + t = Block + { _wlLine = [tl,tr] + , _wlID = k1 + , _wlColor = winCol + , _wlDraw = Nothing + , _wlSeen = False + , _blIDs = ksAtN i + , _blHP = hp + , _wlIsSeeThrough = True + , _blVisible = seen + , _blShadows = shadows + , _blDegrades = degradeHP + } + r = Block + { _wlLine = [tr,br] + , _wlID = k2 + , _wlColor = winCol + , _wlDraw = Nothing + , _wlSeen = False + , _blIDs = ksAtN i + , _blHP = hp + , _wlIsSeeThrough = True + --, _blVisible = False + , _blVisible = isRightmost + , _blShadows = shadows + , _blDegrades = degradeHP + } + b = Block + { _wlLine = [br,bl] + , _wlID = k3 + , _wlColor = winCol + , _wlDraw = Nothing + , _wlSeen = False + , _blIDs = ksAtN i + , _blHP = hp + , _wlIsSeeThrough = True + , _blVisible = seen + , _blShadows = shadows + , _blDegrades = degradeHP + } + f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b + in over walls f w + +autoDoorAt :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall +autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is + where i = newKey wls + is = [i..] + +mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall] +mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr]) + xs + [ [pld,hwd] + , [hwd,hwu] + , [hwu,plu] + , [pru,hwu] + , [hwu,hwd] + , [hwd,prd] + ] + [ [plld,pld] + , [pld,plu] + , [plu,pllu] + , [prru,pru] + , [pru,prd] + , [prd,prrd] + ] + where norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl)) + hw = 0.5 *.* (pl +.+ pr) + perp = 20 *.* normalizeV (pl -.- pr) + plu = pl +.+ norm + pld = pl -.- norm + pru = pr +.+ norm + prd = pr -.- norm + hwu = hw +.+ norm + hwd = hw -.- norm + pllu = plu +.+ perp + plld = pld +.+ perp + prru = pru -.- perp + prrd = prd -.- perp + addSound (x:xs) = f x : xs + f wl = over doorMech g wl + g dm w | dist wp pld > 1 && dist wp hwd > 1 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 + $ dm w + | otherwise = dm w + where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1 + +mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2 +mvPointTowardAtSpeed speed !ep !p + | dist p ep < speed = ep + | otherwise = p +.+ speed *.* normalizeV (ep -.- p) + +mvPointToward :: Point2 -> Point2 -> Point2 +mvPointToward ep p | dist p ep < 1 = ep + | otherwise = p +.+ normalizeV (ep -.- p) + +drawAutoDoor :: Wall -> Drawing +drawAutoDoor wl = onLayerL [levLayer WlLayer, layer2] + $ pictures [color c $ polygon [x,x +.+ n2,y +.+ n2, y] + ,color (dark c) $ line [x,y] + ] + where + (x:y:_) = _wlLine wl + c = _wlColor wl + nm = errorNormalizeV 543 (y -.- x) + t = 5 *.* nm + n = vNormal t + n2 = 3 *.* n + layer2 | _wlIsSeeThrough wl = 0 + | isJust $ wl ^? doorMech = 1 + | otherwise = 2 + +autoDoorPane :: [Point2] -> Int -> [Point2] -> [Point2] -> Wall +autoDoorPane trigL n [a,b] [a',b'] = AutoDoor + { _wlLine = [a,b] + , _wlID = n + , _doorMech = dm + , _wlColor = dim $ yellow + , _wlDraw = Just drawAutoDoor + , _wlSeen = False + , _wlIsSeeThrough = False +-- , _doorLine = [a,b,a',b'] + } + where + dm w | crsNearLine 40 trigL w + = flip (foldr changeZonedWall) zoneps + $ over walls (IM.adjust openDoor n) w + | otherwise = flip (foldr changeZonedWall') zoneps + $ over walls (IM.adjust closeDoor n) w + mvP !ep !p = mvPointTowardAtSpeed 2 ep p + openDoor :: Wall -> Wall + openDoor wl = case _wlLine wl of + ((!pa):(!pb):_) -> wl {_wlLine = [mvP a' pa, mvP b' pb]} + closeDoor :: Wall -> Wall + closeDoor wl = case _wlLine wl of + ((!pa):(!pb):_) -> wl {_wlLine = [mvP a pa, mvP b pb]} + zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b] + | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b + changeZonedWall (!x,!y) + = over wallsZone $ adjustIMZone openDoor x y n + changeZonedWall' (!x,!y) + = over wallsZone $ adjustIMZone closeDoor x y n + +shiftPointBy (pos,rot) p = pos +.+ rotateV rot p + +addWindow :: [Point2] -> Color -> IM.IntMap Wall -> IM.IntMap Wall +addWindow qs c wls = foldr (addPane c) wls pairs + where (p:ps) = orderPolygon qs + pairs = zip (ps ++ [p]) (p:ps) +addPane :: Color -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall +addPane c (p0,p1) wls = IM.insert (newKey wls) (Wall { _wlLine = [p0,p1] + , _wlID = newKey wls + , _wlColor = c + , _wlDraw = Nothing + , _wlSeen = False + , _wlIsSeeThrough = True + } + ) wls + + +placeBt bt p rot w = over buttons addBT w + where addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = newKey bts}) bts +placeFlIt fi p rot w = over floorItems addFI w + where addFI fis = IM.insert (newKey fis) (fi {_flItPos = p, _flItRot = rot, _flItID = newKey fis}) fis +placePressPlate pp p rot w = over pressPlates addPP w + where addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps + +-- Left elements get new children, Right elements inherit the children from the +-- mapped over node +expandTreeBy :: (a -> Tree (Either b b)) -> Tree a -> Tree b +expandTreeBy f (Node x []) = fmap removeEither (f x) + where removeEither (Left y) = y + removeEither (Right y) = y +expandTreeBy f (Node x xs) = appendAndRemove $ f x + where appendAndRemove (Node (Left y) ys) = Node y (map appendAndRemove ys) + appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs) + +expandTreeRand :: RandomGen g => + (a -> State g (Tree (Either b b))) -> Tree a -> State g (Tree b) +expandTreeRand f (Node x []) = fmap (fmap removeEither) (f x) + where removeEither (Left y) = y + removeEither (Right y) = y +expandTreeRand f (Node x xs) = do + root <- f x + branches <- sequence $ map (expandTreeRand f) xs + return (appendAndRemove branches root) + where appendAndRemove :: [Tree a] -> Tree (Either a a) -> Tree a + appendAndRemove bran (Node (Left y) ys) = Node y (map (appendAndRemove bran) ys) + appendAndRemove bran (Node (Right y) _) = Node y bran + +placeCr :: Creature -> Point2 -> Float -> World -> World +placeCr crF p rot w = over creatures addCr w + where addCr crs = IM.insert (newKey crs) + (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs}) + crs + +placeLS :: LightSource -> Drawing -> Point2 -> Float -> World -> World +placeLS ls dec p rot w = over lightSources addLS + $ over decorations addDec w + where addLS lss = IM.insert (newKey lss) + (ls {_lsPos = p,_lsDir = rot,_lsID = newKey lss}) + lss + addDec decs = IM.insert (newKey decs) + (uncurry translate p $ rotate (radToDeg rot) dec) + decs + + diff --git a/src/Dodge/LightSources.hs b/src/Dodge/LightSources.hs new file mode 100644 index 000000000..26d1d38fb --- /dev/null +++ b/src/Dodge/LightSources.hs @@ -0,0 +1,25 @@ +module Dodge.LightSources where +import Dodge.Data +import Dodge.Base + +import Geometry +import Picture + +--import Graphics.Gloss +--import Graphics.Gloss.Data.Vector +--import Graphics.Gloss.Geometry.Line +--import Graphics.Gloss.Geometry.Angle + +import qualified Data.IntMap.Strict as IM + +lightAt p i = + LS {_lsID = i + ,_lsPos = p + ,_lsDir = 0 + ,_lsRad = 300 + ,_lsIntensity = 0.25 + } + +basicLS = PutLS ls dec + where ls = lightAt (0,0) 0 + dec = onLayer PtLayer $ color white $ circleSolid 8 diff --git a/src/Dodge/LoadSound.hs b/src/Dodge/LoadSound.hs new file mode 100644 index 000000000..822665171 --- /dev/null +++ b/src/Dodge/LoadSound.hs @@ -0,0 +1,137 @@ +module Dodge.LoadSound where +-- imports {{{ +import Dodge.Data + +import Data.Maybe +import qualified Data.IntMap.Strict as IM +import qualified Data.Map as M + +import Control.Monad +import Control.Lens + +import qualified SDL.Mixer as Mix + +-- }}} +loadSounds :: IO (IM.IntMap Mix.Chunk) +loadSounds = do +-- pFireSound <- Mix.load "./data/sound/tap3.wav" + pFireSound <- Mix.load "./data/sound/tap3.wav" + click <- Mix.load "./data/sound/click1.wav" + reloadSound' <- Mix.load "./data/sound/reload1.wav" + tone440 <- Mix.load "./data/sound/tone440.wav" + pickupSound' <- Mix.load "./data/sound/pickUp.wav" + putdownSound' <- Mix.load "./data/sound/whiteNoiseFadeOut.wav" + fireSound' <- Mix.load "./data/sound/fire1.wav" + grenadeBang' <- Mix.load "./data/sound/grenade.wav" + tapQuiet' <- Mix.load "./data/sound/tapQuiet.wav" + twoStep' <- Mix.load "./data/sound/twoStep.wav" + healSound' <- Mix.load "./data/sound/heal.wav" + doorSound' <- Mix.load "./data/sound/slideDoor.wav" + twoStepSlow' <- Mix.load "./data/sound/twoStepSlow.wav" + knifeSound' <- Mix.load "./data/sound/knife.wav" + buzzSound' <- Mix.load "./data/sound/buzz.wav" + hitSound' <- Mix.load "./data/sound/hit1.wav" + autoGunSound' <- Mix.load "./data/sound/autoGun.wav" + shotgunSound' <- Mix.load "./data/sound/shotgun.wav" + teleSound' <- Mix.load "./data/sound/tele.wav" + longGunSound' <- Mix.load "./data/sound/longTap.wav" + launcherSound' <- Mix.load "./data/sound/tap4.wav" + smokeTrailSound' <- Mix.load "./data/sound/missileLaunch.wav" + foot1Sound' <- Mix.load "./data/sound/foot1.wav" + foot2Sound' <- Mix.load "./data/sound/foot2.wav" + lasSound' <- Mix.load "./data/sound/tone440sawtooth.wav" + teslaSound' <- Mix.load "./data/sound/Electrical-Welding.wav" + crankSlow' <- Mix.load "./data/sound/crankSlow.wav" + autoB' <- Mix.load "./data/sound/autoB.wav" + mini' <- Mix.load "./data/sound/mini1.wav" + impactA' <- Mix.load "./data/sound/Impact-A.wav" + impactB' <- Mix.load "./data/sound/Impact-B.wav" + impactC' <- Mix.load "./data/sound/Impact-C.wav" + impactD' <- Mix.load "./data/sound/Impact-D.wav" + glassShat1' <- Mix.load "./data/sound/Glass-Bottle-Shattering-A1.wav" + glassShat2' <- Mix.load "./data/sound/Glass-Bottle-Shattering-A2.wav" + glassShat3' <- Mix.load "./data/sound/Glass-Bottle-Shattering-A3.wav" + glassShat4' <- Mix.load "./data/sound/Glass-Bottle-Shattering-A4.wav" + glass1' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A1.wav" + glass2' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A2.wav" + glass3' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A3.wav" + glass4' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A4.wav" + foamSpray' <- Mix.load "./data/sound/foamSprayLoop.wav" + return $ IM.fromList $ zip [0..] + $ [ pFireSound + , click + , reloadSound' + , tone440 + , pickupSound' + , putdownSound' + , fireSound' + , grenadeBang' + , tapQuiet' + , twoStep' + , healSound' + , doorSound' + , twoStepSlow' + , knifeSound' + , buzzSound' + , hitSound' --15 + , autoGunSound' + , shotgunSound' + , teleSound' + , longGunSound' + , launcherSound' + , smokeTrailSound' + , foot1Sound' + , foot2Sound' + , lasSound' + , teslaSound' --25 + , crankSlow' + , autoB' + , mini' + , impactA' + , impactB' --30 + , impactC' + , impactD' + , glassShat1' --33 + , glassShat2' + , glassShat3' + , glassShat4' + , glass1' --37 + , glass2' + , glass3' + , glass4' --40 + , foamSpray' + ] + +-- updateSound :: World -> IO World +-- updateSound w +-- = do forM_ (_soundQueue w) (\n -> Mix.playOn (-1) 0 (_loadedSounds w IM.! n)) +-- fmap (set soundQueue creatureSounds) $ stepSoundTimers $ w +-- -- = return $ set soundQueue creatureSounds w +-- -- = do forM_ (_soundQueue w) (\n -> Mix.playOn (-1) (_loadedSounds w IM.! n) 0) +-- -- fmap (set soundQueue creatureSounds) $ return w +-- where creatureSounds = [] + +soundOnce :: Int -> World -> World +soundOnce i = over soundQueue ((:) i) + +--stepSoundTimers :: World -> IO World +--stepSoundTimers w = M.foldrWithKey stepSoundTimer (return w) (_sounds w) + +-- ok, this is hard to reason about-- bugs can occur because I am unsure when +-- everything is evaluated +--stepSoundTimer :: SoundOrigin -> Sound -> IO World -> IO World +--stepSoundTimer so s w = +-- case _soundChannel s of +-- Nothing -> do w1 <- w +-- let soundChunk = _loadedSounds w1 IM.! _soundType s +---- n <- Mix.playingCount +-- channel <- Mix.playOn (-1) (-1) soundChunk +-- -- w2 <- w -- Note that using w2 instead of w1 in the +-- -- final return breaks the sound sometimes, must be +-- -- something to do with order of evaluation +-- return $ set (sounds . ix so . soundChannel) (Just $ fromIntegral channel) w1 +-- Just channel -> case _soundTime s of +-- x | x > 0 -> fmap (set (sounds . ix so . soundTime) (x-1)) w +-- | x <= 0 -> do Mix.fadeOut channel (fromIntegral $ _soundFadeTime s+ 1) +-- fmap (over sounds (M.delete so)) w +-- the sound fade doesn't seem to like being 0 diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs new file mode 100644 index 000000000..adbde9391 --- /dev/null +++ b/src/Dodge/Menu.hs @@ -0,0 +1,103 @@ +module Dodge.Menu where +-- imports {{{ +import Dodge.Data +import Dodge.Rooms +import Dodge.Initialisation +import Dodge.SoundLogic + +import Data.Tree +import Data.Maybe +import qualified Data.Set as S + +import Control.Lens +import Control.Monad +import Control.Monad.State + + +import System.Exit +import System.Random + +--import Graphics.Gloss.Interface.IO.Game +import SDL +-- }}} + +keyPressedDown :: Event -> Maybe Keycode +keyPressedDown e = case eventPayload e of + KeyboardEvent (KeyboardEventData _ Pressed False keysym) -> Just $ keysymKeycode keysym + _ -> Nothing + +menuEvents :: (Event -> World -> Maybe World) -> Event -> World -> Maybe World +menuEvents f e w = case _menuState w of + LevelMenu _ -> case keyPressedDown e of + Just KeycodeEscape -> Nothing + Just _ -> startLevel w >>= f e + _ -> Just w + PauseMenu -> case keyPressedDown e of + Just KeycodeEscape -> Nothing + Just KeycodeR -> return $ fromMaybe w $ _storedLevel w + Just KeycodeN -> Just $ putSound $ generateLevel 1 + $ initialWorld {_randGen = _randGen w} + Just _ -> unpause w >>= f e + _ -> Just w + GameOverMenu -> case keyPressedDown e of + Just KeycodeEscape -> Nothing + Just KeycodeR -> Just $ fromMaybe w $ _storedLevel w + Just KeycodeN -> Just $ putSound $ generateLevel 1 + $ initialWorld + {_randGen = _randGen w} + _ -> return w + _ -> f e w + where unpause w' = Just $ resumeSound $ + w' {_menuState = InGame,_keys = S.empty} + startLevel = unpause . storeLevel + putSound = id -- set loadedSounds (_loadedSounds w) + + +--- menuCheckKeyEvents :: (Event -> World -> IO World) -> Event -> World -> IO World +--- menuCheckKeyEvents f e w = case _menuState w of +--- LevelMenu _ -> case e of +--- (EventKey (SpecialKey KeyEsc) Down _ _) +--- -> exitSuccess +--- (EventKey _ Down _ _) -> startLevel w >>= f e +--- _ -> return w +--- PauseMenu -> case e of +--- (EventKey (SpecialKey KeyEsc) Down _ _) +--- -> exitSuccess +--- (EventKey (Char 'r') Down _ _) -> return $ fromMaybe w $ _storedLevel w +--- (EventKey (Char 'n') Down _ _) -> fmap putSound $ generateLevel 1 +--- $ initialWorld +--- {_randGen = _randGen w} +--- -- (EventKey (Char 'c') Down _ _) -> unpaused +--- -- (EventKey (Char 'p') Down _ _) -> unpaused +--- -- (EventKey (SpecialKey KeySpace) Down _ _) -> unpaused +--- (EventKey _ Down _ _) -> unpause w >>= f e +--- _ -> return w +--- GameOverMenu -> case e of +--- (EventKey (SpecialKey KeyEsc) Down _ _) +--- -> exitSuccess +--- (EventKey (Char 'r') Down _ _) -> return $ fromMaybe w $ _storedLevel w +--- (EventKey (Char 'n') Down _ _) -> fmap putSound $ generateLevel 1 +--- $ initialWorld +--- {_randGen = _randGen w} +--- -- (EventKey (Char 'c') Down _ _) -> unpaused +--- _ -> return w +--- _ -> f e w +--- where unpause w' = do Mix.resume (-1) +--- return w' {_menuState = InGame,_keys = S.empty} +--- startLevel = unpause . storeLevel +--- putSound = set loadedSounds (_loadedSounds w) +--- -- there might be a better way to pass the loaded sounds around + +updateRandGen :: World -> World +updateRandGen = over randGen (fst . split) + +menuCheckUpdate :: (Float -> World -> IO World) -> Float -> World -> IO World +menuCheckUpdate f t w = case _menuState w of + InGame -> f t w + _ -> return w + +storeLevel :: World -> World +storeLevel w = case _storedLevel w of + Nothing -> set storedLevel (Just w) w + _ -> w + diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs new file mode 100644 index 000000000..ae168e341 --- /dev/null +++ b/src/Dodge/Path.hs @@ -0,0 +1,171 @@ +module Dodge.Path where +import Dodge.Data +import Dodge.Base + +import Geometry + +import Control.Monad + +import Data.List +import Data.Maybe +import Data.Function +import Data.Graph.Inductive.Graph +import qualified Data.HashSet as HS +import qualified Data.Heap as HP + +import qualified Data.Map as M + +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.PatriciaTree +import Data.Graph.Inductive.Query.SP + +worldGraph :: World -> Point2 -> HS.HashSet Point2 +worldGraph w p = HS.unions $ fmap (\q -> HS.fromList $ pointsAlong w p (p +.+ q)) + [(200,0),(-200,0),(0,200),(0,-200)] + +pointsAlong :: World -> Point2 -> Point2 -> [Point2] +pointsAlong w p q = divideLineFixed 50 p p' + where p' = furthestPointWalkable p q $ wallsAlongLine p q w + +divideLineFixed :: Float -> Point2 -> Point2 -> [Point2] +divideLineFixed x a b = fmap (\i -> a +.+ i * x *.* normalizeV (b -.- a)) + $ fmap fromIntegral ns + where numPoints = floor $ dist a b / x + ns = [1 .. numPoints] + +-- ok, astar or something like it + +type SearchedNodes = (HP.MinHeap (Float,(Float,[Point2])), [Point2]) + +stripRight :: Either a b -> b +stripRight (Right x) = x + +stepPath :: (Point2 -> [Point2]) -> Point2 + -> SearchedNodes -> Either [Point2] SearchedNodes +stepPath f p (nextNodes, seenNodes) + = case HP.view nextNodes of + Nothing -> Left [] + Just ((_,(cost,(q:qs))), nextNodes') + | q == p -> Left (q:qs) + | otherwise -> let rs' = f q + rs = rs' \\ seenNodes + newNodes = map (\r -> (cost + dist q r + dist r p + , (cost + dist q r + , (r:q:qs) + ) + ) + ) rs + in Right $ (foldr HP.insert nextNodes' newNodes + , rs ++ seenNodes + ) +stepPath' :: (Point2 -> [Point2]) -> Point2 + -> SearchedNodes -> [Point2] +stepPath' f p s = case stepPath f p s of Left ps -> ps + Right s' -> stepPath' f p s' + +makePath' :: (Point2 -> [Point2]) -> Point2 -> Point2 -> [Point2] +makePath' f s e = stepPath' f e $ (HP.singleton (0,(0,[s])) , []) + +makeNode :: Point2 -> SearchedNodes +makeNode e = (HP.singleton (0,(0,[e])) , []) + + +tp1,tp2,tp3 :: Point2 +tp1 = (0,1) +tp2 = (0,20) +tp3 = (30,40) + +f = incidenceToFunction $ pairsToIncidence [(tp1,tp2),(tp2,tp3) + ,(tp2,tp1) + ,(tp1,tp3)] +g = pairsToIncidence [(tp1,tp2),(tp2,tp3) + ,(tp2,tp1) + ,(tp1,tp3)] + +pathBetween :: Point2 -> Point2 -> World -> Maybe [Point2] +pathBetween a b w = makePath' <$> return (\p -> _pathInc w M.! p) <*> a' <*> b' + where + nsa :: [Point2] + nsa = map snd $ concat $ lookLookups (zoneAroundPoint a) (_pathPoints w) + nsb = map snd $ concat $ lookLookups (zoneAroundPoint b) (_pathPoints w) + --a' = listToMaybe $ sortBy (compare `on` dist a) $ ns + --b' = listToMaybe $ sortBy (compare `on` dist b) $ ns + a' = listToMaybe $ filter (flip (isWalkable a) w) nsa + b' = listToMaybe $ filter (flip (isWalkable b) w) nsb + + + +---- + +makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int] +makePathBetween a b w = join $ sp <$> fmap fst a' <*> fmap fst b' <*> return g + where g = _pathGraph w + nsa = concat $ lookLookups (zoneAroundPoint a) (_pathPoints w) + nsb = concat $ lookLookups (zoneAroundPoint b) (_pathPoints w) +-- a' = listToMaybe $ sortBy (compare `on` dist a . snd) $ filter (flip (isWalkable a) w . snd) ns +-- b' = listToMaybe $ sortBy (compare `on` dist b . snd) $ filter (flip (isWalkable b) w . snd) ns + a' = listToMaybe $ filter (flip (isWalkable a) w . snd) nsa + b' = listToMaybe $ filter (flip (isWalkable b) w . snd) nsb + + + +ezipWith :: Monoid a => (b -> c -> d) -> Either a b -> Either a c -> Either a d +ezipWith f (Right x) (Right y) = Right (f x y) +ezipWith f (Left x) (Right _) = Left x +ezipWith f (Right _) (Left y) = Left y +ezipWith f (Left x) (Left y) = Left (mappend x y) + + +makePathBetween' :: Point2 -> Point2 -> World -> Either String [Int] +makePathBetween' a b w = let g = _pathGraph w + ns = labNodes g + nsa = (_pathPoints w) `ixNZ` a + nsb = (_pathPoints w) `ixNZ` b + a' = case listToMaybe $ sortBy (compare `on` dist a . snd) + -- a' = case listToMaybe + $ filter (flip (isWalkable a) w . snd) ns of + Just p -> Right $ fst p + _ -> Left "FIRST POINT UNSEEN" + b' = case listToMaybe $ sortBy (compare `on` dist b . snd) + -- b' = case listToMaybe + $ filter (flip (isWalkable b) w . snd) ns of + Just p -> Right $ fst p + _ -> Left $ "SECOND POINT UNSEEN" ++ show b + in case ezipWith (\x y -> sp x y g) a' b' of + Right (Just xs) -> Right xs + Right (Nothing) -> Left $ "NO PATH" ++ show a ++ show b ++ show a' ++ show b' + Left m -> Left m + +makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2] +--makePathBetweenPs a b = pathBetween a b +makePathBetweenPs a b w = fmap (mapMaybe (lab g)) $ makePathBetween b a w + where g = _pathGraph w + +makePathBetweenPs' :: Point2 -> Point2 -> World -> Either String [Point2] +makePathBetweenPs' a b w = fmap (mapMaybe (lab g)) $ makePathBetween' a b w + where g = _pathGraph w + + +pointTowardsGoal :: Point2 -> Point2 -> World -> Maybe Point2 +pointTowardsGoal a b w = join $ fmap (listToMaybe . filter (flip (isWalkable a) w)) +-- $ pathBetween a b w + $ makePathBetweenPs a b w +-- + +pointTowardsGoal' :: Point2 -> Point2 -> World -> Either String Point2 +pointTowardsGoal' a b w = join $ fmap (maybeToEither "NOSEEPATH" . listToMaybe . filter (flip (isWalkable a) w)) + $ makePathBetweenPs' b a w + +maybeToEither :: a -> Maybe b -> Either a b +maybeToEither _ (Just x) = Right x +maybeToEither y Nothing = Left y + +pairsToIncidence :: (Eq a,Ord a) => [(a,a)] -> [(a,[a])] +pairsToIncidence = map ((\(xs,ys) -> (head xs,ys)) . unzip) + . groupBy ( (==) `on` fst) + . sort + +incidenceToFunction :: Eq a => [(a,[a])] -> a -> [a] +incidenceToFunction xs a = case lookup a xs of Just ys -> ys + Nothing -> [] + diff --git a/src/Dodge/Prototypes.hs b/src/Dodge/Prototypes.hs new file mode 100644 index 000000000..ee3d84dd5 --- /dev/null +++ b/src/Dodge/Prototypes.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE BangPatterns #-} +module Dodge.Prototypes where + +import Dodge.Data +import Dodge.SoundLogic +import Dodge.Base + +import Geometry +import Picture + +import Control.Lens + +import System.Random + +import qualified Data.IntMap.Strict as IM +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Graph.Inductive.Graph hiding ((&)) +import Data.List + +--import Graphics.Gloss +--import Graphics.Gloss.Data.Vector + +-- defalt datatypes / prototypes {{{ +basicWall = Wall { _wlLine = [(0,0),(50,0)] + , _wlID = 0 + , _wlColor = greyN 0.6 + , _wlDraw = Nothing + , _wlSeen = False + , _wlIsSeeThrough = False + } +basicAutoDoor = AutoDoor { _wlLine = [(0,0),(50,0)] + , _wlID = 0 + , _doorMech = id + , _wlColor = light $ dim $ dim $ dim $ yellow + , _wlDraw = Nothing + , _wlSeen = False + , _wlIsSeeThrough = False + } +basicDoor = Door { _wlLine = [(0,0),(50,0)] + , _wlID = 0 + , _doorMech = id + , _wlColor = light $ dim $ dim $ dim $ yellow + , _wlDraw = Nothing + , _wlSeen = False + , _wlIsSeeThrough = False + } +basicCreature :: Creature +basicCreature = Creature + { _crPos = (0,0) + , _crOldPos = (0,0) + , _crDir = 0 + , _crID = 1 + , _crPict = const $ onLayer CrLayer $ circleSolid 10 + , _crUpdate = \ w f cr -> (f , Just cr) + , _crRad = 10 + , _crMass = 10 + , _crHP = 100 + , _crMaxHP = 150 + , _crInv = IM.empty + , _crInvSel = 0 + , _crAmmo = M.empty + , _crState = basicState + , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10 + } +basicState = CrSt { _goals = [] + , _stance = Stance {_carriage=Walking 0 0,_posture=AtEase} + , _faction = NoFaction + , _crDamage = [] + , _crPastDamage = 0 + , _crSpState = GenCr + , _crApplyDamage = basicApplyDamage' + } +basicEquipment = Equipment + { _itIdentity = Generic + , _itName = "genericEquipment" + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \cr _ -> blank + , _itEffect = NoItEffect + , _itHammer = HammerUp + , _itID = Nothing + , _itAimingSpeed = 1 + , _itAimingRange = 0 + , _itZoom = basicItZoom + , _itInvColor = yellow + , _itInvDisplay = _itName + } +basicItZoom = ItZoom 20 0.2 1 20 0.2 1 +basicConsumable :: Item +basicConsumable = Consumable + { _itIdentity = Generic + , _itName = "genericConsumable" + , _itMaxStack = 9 + , _itAmount = 1 + , _cnEffect = \_ _ -> Nothing + , _itFloorPict = onLayer FlItLayer $ color blue $ circleSolid 3 + , _itEquipPict = \_ _ -> blank + , _itID = Nothing + , _itInvColor = blue + , _itInvDisplay = \it -> _itName it ++ " x" ++ show (_itAmount it) + , _itEffect = wpRecock + , _itHammer = HammerUp + } +basicApplyDamage' :: [DamageType] -> Creature -> (World -> World, Creature) +basicApplyDamage' ds cr = (id, doPoisonDam $ foldr (\d c -> snd $ basicApplyDamage d c) cr ds') + where (ps,ds') = partition isPoison ds + isPoison (PoisonDam {}) = True + isPoison _ = False + poisonDam = quot (max 0 (sum (map _dmAmount ps) - 0)) 10 + doPoisonDam = over crHP (\hp -> hp - poisonDam) + +basicApplyDamage :: DamageType -> Creature -> (World -> World, Creature) +basicApplyDamage (Concussive amount from push pushexp pushRad) cr + = ( id + , over crHP (\hp -> hp - amount) + $ over crPos (+.+ (pushAmount *.* safeNormalizeV (_crPos cr -.- from))) + cr + ) + where pushAmount | dist (_crPos cr) from == 0 + = 0 + | otherwise = min 5 $ + (push*5*pushRad / (dist (_crPos cr) from * _crMass cr))**pushexp +basicApplyDamage (TorqueDam amount rot) cr + = ( id + , over crHP (\hp -> hp - amount) $ over crDir (+ rot) cr) +basicApplyDamage (PushDam amount pback) cr + = ( id + , over crHP (\hp -> hp - amount) $ over crPos (+.+ ((1/_crMass cr) *.* pback )) cr + ) +basicApplyDamage dt cr + = ( id , over crHP (\hp -> hp - _dmAmount dt) cr ) +basicFlIt = FlIt {_flItRot=0,_flIt = basicIt, _flItPos = (0,0), _flItID = 0} +basicIt = Consumable + { _itIdentity = Medkit25 + , _itName = "basicIt" + , _itMaxStack = 3 + , _itAmount = 2 + , _cnEffect = \ _ -> return + , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \cr _ -> blank + , _itID = Nothing + , _itInvDisplay = _itName + , _itInvColor = blue + , _itEffect = NoItEffect + , _itHammer = HammerUp + } +basicButton = Button + { _btPict = onLayer WlLayer $ color red $ polygon $ rectNSEW 5 (-5) 10 (-10) + , _btPos = (0,0) + , _btRot = 0 + , _btEvent = \b w -> set (buttons . ix (_btID b) . btPict) + (onLayer WlLayer $ color red $ polygon $ rectNSEW (-4) (-5) 10 (-10)) + . set (buttons . ix (_btID b) . btState) BtNoLabel + . soundOnce 1 $ w + , _btID = 0 + , _btText = "Button" + , _btState = BtOff + } +basicPT = Particle + { _ptPos = (0,0) + , _ptStartPos = (0,0) + , _ptVel = (0,0) + , _ptPict = blank + , _ptID = 0 + , _ptUpdate = id + } +basicPP = PressPlate + { _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright $ blue) $ circleSolid 5 + , _ppPos = (0,0) + , _ppRot = 0 + , _ppEvent = \pp -> id + , _ppID = -1 + , _ppText = "Pressure plate" + } +-- }}} +basicWorld = World + { _keys = S.empty + , _mouseButtons = S.empty + , _cameraPos = (0,0) + , _cameraAimTime = 0 + , _cameraRot = 0 + , _cameraZoom = 1 + , _cameraCenter = (0,0) + , _creatures = IM.empty + , _creaturesZone = IM.empty + , _clouds = IM.empty + , _cloudsZone = IM.empty + , _itemPositions = IM.empty + , _particles = IM.empty + , _particles' = [] + , _afterParticles' = [] + , _walls = IM.empty + , _wallsZone = IM.empty + , _forceFields = IM.empty + , _floorItems = IM.empty + , _randGen = mkStdGen 2 + , _mousePos = (0,0) + , _testString = [] + , _yourID = 0 + , _worldEvents = id + , _pressPlates = IM.empty + , _buttons = IM.empty + , _soundQueue = [] +-- , _loadedSounds = IM.empty + , _sounds = M.empty + , _corpses = IM.empty + , _decorations = IM.empty + , _unlimitedAmmo = True + , _storedLevel = Nothing + , _menuState = LevelMenu 1 + , _worldState = M.empty + , _lbClickMousePos = (0,0) + , _lbRotation = 0 + , _pathGraph = Data.Graph.Inductive.Graph.empty + , _pathGraph' = [] + , _pathPoints = IM.empty + , _pathInc = M.empty + , _windowX = 800 + , _windowY = 840 + , _smoke = [] + , _mapDisplay = (False, 0.2) + , _lightSources = IM.empty + , _tempLightSources = [youLight] + } +youLight = +-- LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) ) + TLS { _tlsPos = (0,0) + ,_tlsRad = 300 + ,_tlsIntensity = 0.1 + ,_tlsUpdate = \w _ -> (w, Just (youLight {_tlsPos = _crPos (you w)})) + } + + +wpRecock :: ItEffect +--wpRecock = NoItEffect +wpRecock = ItInvEffect {_itInvEffect = f + ,_itEffectCounter = 0 + } + where f cr i = creatures . ix (_crID cr) . crInv + -- . ix i . itHammer %~ ($!) (fmap $! (moveHammerUp `seq` moveHammerUp)) + -- . ix i . itHammer %~ ($!) (fmap $! moveHammerUp) + -- . ix i . itHammer . _Just %~ ($!) moveHammerUp + %~ IM.adjust fOnIt i + moveHammerUp !HammerDown = HammerReleased + moveHammerUp !HammerReleased = HammerUp + moveHammerUp !HammerUp = HammerUp + fOnIt it = it & itHammer %~ moveHammerUp + diff --git a/src/Dodge/RandomHelp.hs b/src/Dodge/RandomHelp.hs new file mode 100644 index 000000000..4e201ee3b --- /dev/null +++ b/src/Dodge/RandomHelp.hs @@ -0,0 +1,66 @@ +module Dodge.RandomHelp where + +import Geometry +import Geometry.Data + +import System.Random +import Control.Monad.State +import Data.List + +randomRanges :: (Random a,RandomGen g) => [a] -> State g a +randomRanges xs = join $ takeOne $ f xs + where f (x:y:ys) = (state (randomR (x,y))) : (f ys) + f _ = [] + +takeOne :: RandomGen g => [a] -> State g a +takeOne xs = state (randomR (0,length xs - 1)) >>= (\i -> return (xs !! i)) + +takeOneWeighted :: (RandomGen g, Random b, Ord b, Num b) => [b] -> [a] -> State g a +takeOneWeighted ws xs = state (randomR (0, sum ws)) + >>= (\w -> return (xs !! (i w ws))) + where i y (z:zs) | y <= z = 0 + | otherwise = 1 + i (y-z) zs + i y _ = 0 + +takeOneMore :: RandomGen g => ([a],[a]) -> State g ([a],[a]) +takeOneMore (xs,ys) = do + i <- state $ randomR (0,length ys - 1) + let (zs, w:ws) = splitAt i ys + return (w:xs, zs ++ ws) + +takeNMore :: RandomGen g => Int -> ([a],[a]) -> State g ([a],[a]) +takeNMore n p = foldr (const ((=<<) takeOneMore)) (return p) [1..n] + +takeN :: RandomGen g => Int -> [a] -> State g [a] +takeN i xs = fmap fst $ takeNMore i ([],xs) + +-- to randomly shuffle a list +shuffle :: RandomGen g => [a] -> State g [a] +shuffle xs = do + let l = length xs + rands <- forM [0..l-1] $ \i -> state $ randomR (0,i) + let f ys rand = let (as,b:bs) = splitAt rand ys + in (as ++ bs, b) + let (_,zs) = mapAccumR f xs rands + return zs + +randomSelectionFromList :: RandomGen g => Float -> [a] -> State g [a] +randomSelectionFromList p = filterM $ const $ randProb p + +randProb :: RandomGen g => Float -> State g Bool +randProb p = do p1 <- state $ randomR (0,1) + return (p1 < p) + +randInCirc :: RandomGen g => Float -> State g Point2 +randInCirc maxRad = do rad <- state $ randomR (0,maxRad) + ang <- state $ randomR (0,2*pi) + return $ rad *.* unitVectorAtAngle ang + +randInRect :: RandomGen g => Float -> Float -> State g Point2 +randInRect w h = do x <- state $ randomR (0,w) + y <- state $ randomR (0,h) + return (x,y) + +maybeTakeOne :: RandomGen g => [a] -> State g (Maybe a) +maybeTakeOne [] = return Nothing +maybeTakeOne xs = state (randomR (0,length xs - 1)) >>= (\i -> return (Just (xs !! i))) diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs new file mode 100644 index 000000000..681a224e0 --- /dev/null +++ b/src/Dodge/Rendering.hs @@ -0,0 +1,512 @@ +module Dodge.Rendering where +-- imports {{{ +import Dodge.Data +import Dodge.Base +import Geometry +import Picture + +import Data.Graph.Inductive.Query.DFS +import Data.Graph.Inductive.Graph + +import Control.Monad.State +import Data.List +import Data.Bifunctor + + +import Data.Function +import Control.Applicative +import Control.Lens +import Data.Maybe +import qualified Data.IntMap.Strict as IM +import qualified Data.Map as M +import qualified Data.Set as S + +-- }}} +-- +drawTest :: World -> Picture +drawTest w = screenT $ color red $ circle 200 + where (x,y) = (_windowX w,_windowY w) + screenT = scale (1/x) (1/y) + + +draw' :: Picture -> World -> ([((Float,Float),(Float,Float))] + ,[((Float,Float),Float,Float)] + ,Picture,Picture) +draw' p w = (\(x,y) -> (wallsForGloom w,lightsForGloom w,x,y)) (draw'' p w) + +draw :: Picture -> World -> Picture +draw p w = (\(x,y) -> f $ pictures [x,y]) $ draw'' p w + where f = scale (2/_windowX w) (2/_windowY w) + +draw'' :: Picture -> World -> (Picture , Picture) +draw'' b w-- | (Char 'm') `S.member` _keys w + -- = let a = (-500,30) + -- b = (200,0) + -- in pictures [ color white $ polygon screenBox + -- , color blue $ circleSolid 40 + -- , line [a,b] + -- , uncurry translate (ssaTriPoint a (0,0) b 40) + -- $ color red $ circleSolid 5 + -- ] + = case _mapDisplay w of + (True, z) -> (blank + ,pictures [color white $ circleSolid 3 + ,scale z z $ rotate (radToDeg (_cameraRot w)) + $ uncurry translate ((0,0) -.- _cameraCenter w) + $ pictures $ mapMaybe mapWall $ IM.elems $ _walls w] + ) + _ -> ( blank + --,pictures $ map fst pics + ,collectDrawings w + ) +-- ++ map screenShift (pathsTest ++ map drawNode (labNodes $ _pathGraph w)) + where yourPos = _crPos $ you w + backgroundTile = [screenShift $ translate (5*512*x) (5*512*y) $ scale 5 5 b | x <- [x1..x2] , y <- [y1..y2] ] + where (x',y') = yourPos + (x'',y'') = (fromIntegral $ round (x'/(512*5)), fromIntegral $ round (y'/(512*5))) + x1 = (x''-1) + x2 = (x''+1) + y1 = (y''-1) + y2 = (y''+1) + screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) ) + . uncurry translate ((0,0) -.- _cameraPos w) + zoom = _cameraZoom w + pathsTest = map drawPair $ _pathGraph' w + drawPair (x,y) = color cyan $ pictures [line [x,y] + -- , uncurry translate x $ scale 0.05 0.05 $ text $ show x + ] + drawNode (i,x) = color yellow $ uncurry translate x $ scale 0.05 0.05 $ text $ show i + +collectDrawings :: World -> Picture +collectDrawings w = screenShift (decPicts <> ppPicts <> itFloorPicts + <> crPicts + <> clPicts + <> buttonPicts <> ptPicts + <> ptPicts' + <> afterPtPicts' + <> wlPicts + <> wallShadows + <> smokeShadows + ) + <> onLayer LabelLayer + (itLabels <> ppLabels <> btLabels) + <> hudDrawings w + <> onLayer MenuLayer menuScreen +-- <> [onLayer GloomLayer $ theLighting w] + where + screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) ) + . uncurry translate ((0,0) -.- _cameraPos w) + rotPicts = map (scale zoom zoom . rotate (radToDeg (_cameraRot w))) + zoom = _cameraZoom w + decPicts :: Picture + decPicts = mconcat $ IM.elems $ _decorations w + ptPicts = mconcat $ map _ptPict (IM.elems (_particles w)) + ptPicts' = mconcat $ map _ptPict' $ _particles' w + afterPtPicts' = mconcat $ map _ptPict' $ _afterParticles' w + buttonPicts = mconcat $ map btDraw (IM.elems (_buttons w)) + ppPicts = mconcat $ map ppDraw (IM.elems (_pressPlates w)) + crPicts :: Picture + crPicts = mconcat $ map crDraw $ IM.elems $ _creatures w + clPicts = mconcat $ map clDraw $ IM.elems $ _clouds w + wallShadows = mconcat $ map (drawWallShadow w) $ wallShadowsToDraw w + smokeShadows = mconcat $ map (drawSmokeShadow w) $ _smoke w + wlPicts = mconcat $ map drawWall (wallsToDraw w) + yourPos = _crPos $ you w + yourRot = _crDir $ you w + yourRad = _crRad $ you w + -- itFloorPicts = zipWith (uncurry translate) (map _flItPos (IM.elems (_floorItems w))) + -- (map (_itFloorPict . _flIt) (IM.elems (_floorItems w))) + itFloorPicts = mconcat $ map (drawItem) (IM.elems (_floorItems w)) + itLabels = mconcat $ map (drawItemName w) (IM.elems (_floorItems w)) + ppLabels = mconcat $ map (drawPPText w) (IM.elems (_pressPlates w)) + btLabels = mconcat $ map (drawButText w) (IM.elems (_buttons w)) + menuScreen :: Picture + menuScreen = case _menuState w of + InGame -> blank + LevelMenu x -> + mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w + ,tst (-100) 100 0.4 ("LEVEL "++show x) + ] <> controlsList + PauseMenu -> mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w + ,tst (-100) 100 0.4 "PAUSED" + ,tst (-100) 50 0.2 "n - new level" + ,tst (-100) 0 0.2 "r - restart" + ] <> controlsList + GameOverMenu -> mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w + ,tst (-100) 100 0.4 "GAME OVER" + ,tst (-100) 50 0.2 "n - new level" + ,tst (-100) 0 0.2 "r - restart" + ] + <> controlsList + where tst x y sc t = translate x y $ scale sc sc $ color white $ text t + +hudDrawings :: World -> Picture +hudDrawings w = (onLayer InvLayer) + $ displayInv 0 w + <> mconcat + [ dShadCol white $ displayHP 0 w + , dShadCol (itCol (yourItem w)) + $ drawCursor w, translate (-390) 20 + $ scale 0.05 0.05 $ dShadCol white $ text (_testString w) + ] + where itCol = fromMaybe (greyN 0.5) . (^? itInvColor) + +crDraw :: Creature -> Drawing +crDraw c = uncurry translateDrawing (_crPos c) $ rotateDrawing (- radToDeg (_crDir c)) (_crPict c c) +ppDraw :: PressPlate -> Drawing +ppDraw c = uncurry translateDrawing (_ppPos c) $ rotateDrawing (- radToDeg (_ppRot c)) (_ppPict c) +btDraw :: Button -> Drawing +btDraw c = uncurry translateDrawing (_btPos c) $ rotateDrawing (- radToDeg (_btRot c)) (_btPict c) + +clDraw :: Cloud -> Drawing +clDraw c = uncurry translateDrawing (_clPos c) $ (_clPict c c) + +drawCursor :: World -> Picture +drawCursor w = translate (105-halfWidth w) + (halfHeight w - (25* (fromIntegral iPos)) - 20 + ) + -- $ rectangleWire 200 25 + $ line [(200,12.5),(-100,12.5),(-100,-12.5),(200,-12.5)] + where iPos = _crInvSel $ _creatures w IM.! _yourID w + + +controlsList = mconcat [tst (-250) (-130) 0.15 "controls:" + ,tst (-150) (-130) 0.15 "wasd" + ,tst 0 (-130) 0.15 "movement" + ,tst (-150) (-160) 0.15 "[rmb]" + ,tst 0 (-160) 0.15 "aim" + ,tst (-150) (-190) 0.15 "[rmb+lmb]" + ,tst 0 (-190) 0.15 "shoot or use item" + ,tst (-150) (-220) 0.15 "[wheelscroll]" + ,tst 0 (-220) 0.15 "select item" + ,tst (-150) (-250) 0.15 "[space]" + ,tst 0 (-250) 0.15 "pickup item" + ,tst (-150) (-280) 0.15 "f" + ,tst 0 (-280) 0.15 "drop item" + ,tst (-150) (-310) 0.15 "cp[esc]" + ,tst 0 (-310) 0.15 "pause" + ,tst (-150) (-340) 0.15 "qe[lmb]" + ,tst 0 (-340) 0.15 "rotate camera" + ] + where tst x y sc t = translate x y $ scale sc sc $ color white $ text t + +screenBox w = [ (halfWidth w, halfHeight w) + , (-halfWidth w, halfHeight w) + , (-halfWidth w,-halfHeight w) + , ( halfWidth w,-halfHeight w) + ] + +mapWall :: Wall -> Maybe Picture +mapWall wl = + case _wlSeen wl of + False -> Nothing + True -> Just $ color c $ polygon [x,x +.+ n2,y +.+ n2, y] + where t = 5 *.* errorNormalizeV 68 (y -.- x) + n = vNormal t + n2 = 4 *.* n + (x:y:_) = _wlLine wl + c = _wlColor wl + +wallsToDraw :: World -> [Wall] +wallsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w + where onScreen wall = lineOnScreen w (_wlLine wall) + isVisible wl | wl ^? blVisible == Just False = False + | otherwise = onScreen wl + +wallsOnScreen :: World -> IM.IntMap Wall +wallsOnScreen w = wallsNearZones (zoneOfScreen w) w + +drawSmokeShadow :: World -> Smoke -> Drawing +drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps, _smTime = t}) + = ( + onLayerL [74,0] $ color col $ + pictures [uncurry translate p $ circle r' + ,line $ (\(x,y) -> [x,y]) $ smokePerpLine (_cameraPos w) p sm + ,line [_cameraPos w, mouseWorldPos w] + ,trap' p + ] + ) + <> + (onLayerL [74] $ color (withAlpha 0.1 c) $ pictures + $ concatMap (f . (+.+ p)) p's + ) + where + r = r'/2 + col | smokeLOS (_cameraPos w) (mouseWorldPos w) w = red + | otherwise = green + orth p' = r *.* (safeNormalizeV $ vNormal $ p' -.- _cameraCenter w) + pa p' = p' +.+ orth p' + pb p' = p' -.- orth p' + pao p' = pa p' +.+ l *.* safeNormalizeV (pa p' -.- _cameraCenter w) + pbo p' = pb p' +.+ l *.* safeNormalizeV (pb p' -.- _cameraCenter w) + semiCirc p' = uncurry translate p' $ rotate (radToDeg (a p')) $ arcSolid 0 180 r + a p' = pi - argV (orth p') + trap p' = polygon [pa p', pb p', pbo p', pao p'] + f p' = [semiCirc p', trap p'] + p's = zipWith (\x p -> rotateV (x * fromIntegral t / 60) p) xs ps + xs = concat $ repeat [-1,-0.5,0,0.5,1] + l = _windowX w + _windowY w + magV (_cameraPos w -.- _cameraCenter w) +-- cenpic = color (withAlpha 0.5 c) $ pictures $ f p + orth' p' = r' *.* (safeNormalizeV $ vNormal $ p' -.- _cameraCenter w) + pa' p' = p' +.+ orth' p' + pb' p' = p' -.- orth' p' + pao' p' = pa' p' +.+ l *.* safeNormalizeV (pa' p' -.- _cameraCenter w) + pbo' p' = pb' p' +.+ l *.* safeNormalizeV (pb' p' -.- _cameraCenter w) + trap' p' = line [pa' p', pb' p', pbo' p', pao' p',pa' p'] + semiCirc' p' = uncurry translate p' $ rotate (radToDeg (a p')) $ arcSolid 0 180 r' + + +drawWall :: Wall -> Drawing +drawWall wl = case _wlDraw wl of + Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon [x,x +.+ n2,y +.+ n2, y] + Just d -> d wl + where + (x:y:_) = _wlLine wl + c = _wlColor wl + t = 5 *.* errorNormalizeVDR (y -.- x) + n = vNormal t + n2 = 3 *.* n + layer2 | _wlIsSeeThrough wl = 0 + | isJust $ wl ^? doorMech = 1 + | otherwise = 2 +-- wallOrdering wl = (not $ _wlIsSeeThrough wl, not $ isJust $ wl ^? doorMech) + +errorNormalizeVDR :: Point2 -> Point2 +errorNormalizeVDR (0,0) = error $ "problem with function: errorNormalizeVDR in DodgeRendering" +errorNormalizeVDR p = normalizeV p + +printPoint :: Point2 -> Picture +printPoint p = color white $ uncurry translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)] + +printRotPoint :: Float -> Point2 -> Picture +printRotPoint r p = color white $ uncurry translate p $ pictures [circle 3 + , rotate r $ scale 0.1 0.1 $ text (show p)] + +outsideScreenPolygon :: World -> [Point2] +outsideScreenPolygon w = [tr,tl,bl,br] + where scRot = rotateV (_cameraRot w) + scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p + scTran p = p +.+ _cameraPos w + tr = scTran $ scRot $ scZoom ( 3*halfWidth w , 3* halfHeight w) + tl = scTran $ scRot $ scZoom (- (3*halfWidth w), 3* halfHeight w) + br = scTran $ scRot $ scZoom ( 3*halfWidth w ,- (3* halfHeight w)) + bl = scTran $ scRot $ scZoom (- (3*halfWidth w),- (3* halfHeight w)) + x = halfWidth w + halfHeight w + +-- wallShadowsToDrawOnScreen :: World -> [Wall] +-- wallShadowsToDrawOnScreen w = --IM.elems $ _walls w +-- sortBy (compare `on` not . _wlIsSeeThrough) $ filter isVisible $ IM.elems +-- $ _walls w +-- -- $ wallsOnScreen w +-- -- should really sort this out +-- where onScreen wall = lineOnScreen w (_wlLine wall) +-- isVisible wl | wl ^? blVisible == Just False = False +-- | otherwise = onScreen wl + +wallShadowsToDraw :: World -> [Wall] +wallShadowsToDraw w = --IM.elems $ _walls w + filter isVisible $ IM.elems -- $ _walls w + $ wallsNearZones (zoneOfSight w) w +-- should really sort this out + where onScreen wall = True -- lineOnScreenCone w (_wlLine wall) + isVisible wl | wl ^? blVisible == Just False = False + | otherwise = onScreen wl + +-- cannot only test if walls are on screen, but also if they are on the cone +-- towards the center of sight +lineOnScreenCone :: World -> [Point2] -> Bool +lineOnScreenCone w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp + || any (isJust . uncurry (intersectSegSeg' p1 p2)) sps + where sp' = screenPolygon w + vp = _cameraCenter w + sp | pointInPolygon vp sp' = sp' + | otherwise = orderPolygon $ (_cameraCenter w : sp') + sps = zip sp (tail sp ++ [head sp]) + + +lineOnScreen :: World -> [Point2] -> Bool +lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp + || any (isJust . uncurry (intersectSegSeg' p1 p2)) sps + where sp = screenPolygon w + sps = zip sp (tail sp ++ [head sp]) + + +drawWallShadow :: World -> Wall -> Drawing +drawWallShadow w wall + | isRHS sightFrom x y = blank + | otherwise = onLayerL l $ color shadCol $ polygon $ points + where + l | _wlIsSeeThrough wall = [levLayer ShadowLayer] + | otherwise = [levLayer ShadowLayer, 0] + (x:y:_) = _wlLine wall + ps = linePointsBetween x y + ds = map (\p -> safeNormalizeV (p -.- sightFrom)) ps + p's = zipWith (\d x -> (15 *.* d) +.+ x) ds ps + sightFrom = _cameraCenter w + shadCol = if _wlIsSeeThrough wall then withAlpha 0.2 $ _wlColor wall + else black + corns = screenPolygon w + borders = filter g $ zip corns (tail corns ++ [head corns]) + g (a,b) = isLHS a b sightFrom + borderps = mapMaybe f borders ++ mapMaybe f' borders ++ shadowedCorners + coneTop = nub $ concatMap (\(a,b) -> [a,b]) $ borders + shadowedCorners = filter isShadowed coneTop + isShadowed p = isLHS sightFrom x p && isRHS sightFrom y p + f (bpa,bpb) = intersectSegLineFrom' bpa bpb x (head p's) + f' (bpa,bpb) = intersectSegLineFrom' bpa bpb y (last p's) + points = orderPolygon (borderps ++ p's) + +linePointsBetween :: Point2 -> Point2 -> [Point2] +linePointsBetween p p' | d > 99 = map (\m -> p +.+ fromIntegral m *.* p'') [0..n-1] ++ [p'] + | otherwise = [p,p'] + where d = dist p p' + n = ceiling $ d / 50 + p'' = (1/fromIntegral n) *.* (p' -.- p) + +displayInv :: Int -> World -> Picture +displayInv n w = mconcat $ zipWith (translate (10-halfWidth w)) + (map (\x-> halfHeight w-(25*(fromIntegral x+1))) ns) $ map dItem' is + where (ns,is) = unzip $ IM.toList $ _crInv $ _creatures w IM.! n + +dItem' NoItem = scale 0.15 0.15 $ dShadCol (greyN 0.5) $ text "----" +dItem' i = scale 0.15 0.15 $ pictures [dropShadow t, color (_itInvColor i) t] + where t = text $ _itInvDisplay i i + +displayAmount :: Int -> String +displayAmount n | n > 1 = "-x" ++show n + | otherwise = [] + +rectangleSolid x y = polygon [(x,y),(x,-y),(-x,-y),(-x,y)] + +drawItem :: FloorItem -> Drawing +drawItem (FlAm {_flItPos = p}) = uncurry translateDrawing p $ onLayer FlItLayer $ rectangleSolid 5 5 +drawItem flIt = uncurry translateDrawing (_flItPos flIt) + $ rotateDrawing (radToDeg $ _flItRot flIt) (_itFloorPict (_flIt flIt)) + +drawButText :: World -> Button -> Picture +drawButText w bt | magV (_crPos (you w) -.- _btPos bt) < 100 + && hasLOS (_btPos bt) (_crPos (you w)) w + && _btState bt /= BtNoLabel + = t $ rotate (radToDeg (-_cameraRot w)) + $ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)] + , scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)] + ,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white + $ scale 0.1 0.1 $ text $ _btText bt + ] + | otherwise = blank + where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_btPos bt -.- _cameraPos w)) + zoom = _cameraZoom w + scLine = dShadCol white . line . fmap (sqrt zoom *.*) + +drawPPText :: World -> PressPlate -> Picture +drawPPText w pp | magV (_crPos (you w) -.- _ppPos pp) < 100 + && hasLOS (_ppPos pp) (_crPos (you w)) w + = t $ rotate (radToDeg (-_cameraRot w)) + $ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)] + , scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)] + ,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white + $ scale 0.1 0.1 $ text $ _ppText pp + ] + | otherwise = blank + where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_ppPos pp -.- _cameraPos w)) + zoom = _cameraZoom w + scLine = dShadCol white . line . fmap (sqrt zoom *.*) + +drawItemName :: World -> FloorItem -> Picture +drawItemName w flIt | magV (_crPos (you w) -.- _flItPos flIt) < 100 + && hasLOS (_flItPos flIt) (_crPos (you w)) w + = t $ rotate (radToDeg (-_cameraRot w)) + $ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)] + , scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)] + ,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white + $ scale 0.1 0.1 $ text $ nameOfItem + ] + | otherwise = blank + where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_flItPos flIt -.- _cameraPos w)) + nameOfItem = case flIt of FlIt {} -> _itName $ _flIt flIt + FlAm {_flAm = PistolBullet} -> "Bullets" + FlAm {_flAm = LiquidFuel} -> "Liquid Fuel" + zoom = _cameraZoom w + scLine = dShadCol white . line . fmap (sqrt zoom *.*) + +ringPict :: Drawing +ringPict = onLayer LabelLayer $ dShadCol white $ pictures [line [(-8,10),(-15,10),(-15,-10),(-8,-10)] + ,line [( 8,10),( 15,10),( 15,-10),( 8,-10)] + ] + +dShadCol :: Color -> Picture -> Picture +dShadCol c p = pictures $ + map (flip (uncurry translate) p) [(0.2,-0.2) + ,(0.4,-0.4) + ,(0.6,-0.6) + ,(0.8,-0.8) + ,( 1,- 1) + ,(1.2,-1.2) + ] ++ [color c p] + +dropShadow :: Picture -> Picture +dropShadow p = pictures [ translate 5 (-5) p + , translate 1 (-1) p + , translate 2 (-2) p + , translate 3 (-3) p + , translate 4 (-4) p + , translate 6 (-6) p + , translate 7 (-7) p + , translate 8 (-8) p + , translate 9 (-9) p + ] + +ffToDraw :: World -> [ForceField] +ffToDraw w = filter (lineOnScreen w . _ffLine) $ + IM.elems $ fmap (over ffLine (map (\p->p -.- _cameraPos w))) $ + _forceFields w + +drawFF :: ForceField -> Picture +drawFF (FF {_ffLine = l, _ffColor = col}) = pictures [color white $ line l, color col + $ lineOfThickness 6 l ] + + +drawFFShadow :: World -> ForceField -> [Picture] +drawFFShadow w ff + | youOnFF = [] + | otherwise = map (rotate (radToDeg (- _cameraRot w)) . pane) + [0,0.05..0.25] + where p = rotateV (-_cameraRot w) $ ypShift + x = rotateV (-_cameraRot w) x' + y = rotateV (-_cameraRot w) y' + yp = _crPos $ you w + (x1:y1:_) = _ffLine ff + (x':y':_) | isRHS x1 y1 yp = (y1:x1:[]) + | otherwise = (x1:y1:[]) + fCol = color (_ffColor ff) + col = _ffColor ff + ypShift = yp -.- _cameraPos w + youOnFF = circOnLine' x' y' ypShift (_crRad $ you w) + pane j = color (withAlpha 0.1 col) + $ polygon + $ [ x + , x +.+ ((0.1 + j) *.* (x -.- ypShift)) + , y +.+ ((0.1 + j) *.* (y -.- ypShift)) + , y] + +displayHP :: Int -> World -> Picture +displayHP n w = translate (halfWidth w-70) (halfHeight w-40) $ + scale 0.2 0.2 $ text $ show + $ _crHP $ _creatures w IM.! n + +testPic w = blank + +wallsForGloom :: World -> [(Point2,Point2)] +wallsForGloom w = map (\(x:y:_) -> (screenShift x,screenShift y)) $ + map _wlLine $ filter (not . _wlIsSeeThrough) + $ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w + where screenShift x = zoom *.* rotateV (0 - _cameraRot w) (x -.- _cameraPos w) + zoom = _cameraZoom w + + +lightsForGloom :: World -> [(Point2,Float,Float)] +lightsForGloom w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w) + where getLS ls = (screenShift $ _lsPos ls, _lsRad ls * zoom, _lsIntensity ls) + getTLS ls = (screenShift $ _tlsPos ls, _tlsRad ls * zoom, _tlsIntensity ls) + screenShift x = zoom *.* rotateV (0 - _cameraRot w) (x -.- _cameraPos w) + zoom = _cameraZoom w diff --git a/src/Dodge/Rooms.hs b/src/Dodge/Rooms.hs new file mode 100644 index 000000000..5fd2f8e9b --- /dev/null +++ b/src/Dodge/Rooms.hs @@ -0,0 +1,874 @@ +module Dodge.Rooms where +-- imports {{{ +import Dodge.Data +import Dodge.Weapons +import Dodge.Critters +import Dodge.LevelGen +import Dodge.Base +import Dodge.RandomHelp +import Dodge.Prototypes +import Dodge.Path +import Dodge.Layout +import Dodge.LightSources +import Dodge.SoundLogic + +import Geometry +import Picture + +import qualified SDL.Mixer as Mix + +import Control.Monad.State +import Control.Monad.Loops +import Control.Lens +import System.Random + +import Data.List +import Data.Maybe +import Data.Tree +import Data.Either +import Data.Function +import qualified Data.Map as M + +import Data.Graph.Inductive.Graph hiding ((&)) +import Data.Graph.Inductive.Basic +import Data.Graph.Inductive.PatriciaTree +import Data.Graph.Inductive.NodeMap + +import qualified Data.IntMap.Strict as IM +-- }}} + + + +lev1 :: RandomGen g => State g (Tree Room) +lev1 = do + firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom] + iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id) + $ sequence $ treePost + ( +-- [randomiseLinks =<< pistolerRoom] + [return $ return $ Right deadEndRoom + ] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] +-- ++ [randomiseLinks =<< longRoom] + ++ [randomiseLinks =<< pistolerRoom] +-- ++ [randomiseLinks =<< shooterRoom] + ++ [return $ connectRoom door] + -- ++ [return $ connectRoom $ set rmPS [PS (100,100) 0 $ PutCrit explosiveBarrel + -- ,PS (105,110) 0 $ PutCrit explosiveBarrel + -- ,PS (115,110) 0 $ PutCrit autoCrit + -- ,PS (135,110) 0 $ PutCrit explosiveBarrel + -- ,PS (105,140) 0 $ PutCrit explosiveBarrel + -- ] + -- $ roomRect 300 300] + ++ [randomiseLinks =<< shooterRoom] + ++ (replicate 3 $ randomiseLinks corridor) + ++ [return $ connectRoom corridor] +-- ++ [randomiseLinks =<< longRoom] + ++ [return $ connectRoom corridor] + ++ firstWeapon + ++ (replicate 3 $ randomiseLinks corridor) + ++ [return $ connectRoom corridor] + ++[return $ connectRoom corridor,return $ connectRoom door] + ++ [shootingRange] + ++ (replicate 3 $ randomiseLinks corridor) + ++[roomMiniIntro] + ++ (replicate 3 $ randomiseLinks corridor) + ++ [return $ connectRoom corridor + ,return $ connectRoom door + ,slowDoorRoom] + ++ [return $ connectRoom corridor + ,spawnerRoom + ,return $ connectRoom corridor + ] + ) + $ randomiseLinks corridor + + + + +generateLevel :: Int -> World -> World +generateLevel i w = + do haltSound $ ((generateFromTree $ levelTree i) w) + +levelTree :: Int -> State StdGen (Tree Room) +levelTree 1 = lev1 + +levelPortalAt :: Point2 -> Int -> PressPlate +levelPortalAt p x + = PressPlate + { _ppPict = onLayer PressPlateLayer $ color blue $ circle 10 + , _ppPos = p + , _ppRot = 0 + , _ppEvent = \pp w -> if dist (_crPos (you w)) (_ppPos pp) < 10 + then generateLevel x w + else w + , _ppID = -1 + , _ppText = "Portal to level "++ show x + } + +airlockOneWay :: Int -> Room +airlockOneWay n = Room + { _rmPolys = [rectNSWE 90 0 0 40] + , _rmLinks = lnks + , _rmPath = [] + , _rmPS = [PS (0,15) 0 $ PutTriggerDoor col (not . cond) (0,0) (0,40) + ,PS (0,75) 0 $ PutTriggerDoor col (cond) (0,0) (0,40) + ,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState + (M.insert (DoorNumOpen n) True)) + ] + --, _rmBound = rectNSWE 90 30 (-30) 30 + , _rmBound = rectNSWE 75 15 0 40 + } + where lnks = [((0,85),0) + ,((0, 5),pi) + ] + cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) + col = dim $ dim $ bright red +airlock :: Int -> Room +airlock n = Room + { _rmPolys = [rectNSWE 90 0 0 40] + , _rmLinks = lnks + , _rmPath = [((20,85),(20,45)) + ,((20,45),(20, 5)) + ] + , _rmPS = [PS (0,15) 0 $ PutTriggerDoor col (not . cond) (0,0) (40,0) + ,PS (0,75) 0 $ PutTriggerDoor col (cond) (0,0) (40,0) + ,PS (35,45) (pi/2) $ PutButton $ makeSwitch col + (over worldState (M.insert (DoorNumOpen n) True)) + (over worldState (M.insert (DoorNumOpen n) False)) + ] + , _rmBound = rectNSWE 75 15 0 40 + } + where lnks = [((20,85),0) + ,((20, 5),pi) + ] + cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) + col = dim $ dim $ bright red +corridor :: Room +corridor = Room + { _rmPolys = [rectNSWE 80 0 0 40 + ,[(0,80), (0,80) +.+ rotateV (pi/3) (40,0),(40,80)] + ,[(40,0), (0,0) +.+ rotateV (0-pi/3) (40,0),( 0, 0)] + ] + , _rmLinks = lnks + , _rmPath = concatMap (doublePair . (,) (20,60)) $ map fst lnks + , _rmPS = [] + , _rmBound = rectNSWE 50 30 0 40 + } + where lnks = [((20,70) ,0) + ,((20,80) +.+ rotateV (0-pi/3) (-20,0), pi/6) + ,((20,80) +.+ rotateV ( pi/3) ( 20,0),0-pi/6) +-- ,((40,0) +.+ rotateV ( pi/3) (-20,0), 2*pi/3) +-- ,(( 0,0) +.+ rotateV (0-pi/3) ( 20,0),0-2*pi/3) + ,((20,10) ,pi) + ] +corridorN :: Room +corridorN = Room + { _rmPolys = [rectNSWE 80 0 0 40 + ] + , _rmLinks = lnks + , _rmPath = pth + , _rmPS = [] + , _rmBound = rectNSWE 50 30 0 40 + } + where lnks = [((20,70) ,0) + ,((20,10) ,pi) + ] + pth = doublePair ((20,70),(20,10)) +tEast :: Room +tEast = Room + { _rmPolys = [rectNSWE 80 0 (-20) (20) + ,rectNSWE 80 40 (-40) 40 + ] + , _rmLinks = lnks + , _rmPath = concatMap (doublePair . (,) (0,60)) $ map fst lnks + , _rmPS = [] + , _rmBound = rectNSWE 70 10 0 40 + } + where lnks = [(( 30,60),-pi/2) + ,((-30,60),pi/2) + ,((0,10),pi) + ] +tWest :: Room +tWest = Room + { _rmPolys = [rectNSWE 80 0 (-20) (20) + ,rectNSWE 80 40 (-40) 40 + ] + , _rmLinks = lnks + , _rmPath = concatMap (doublePair . (,) (0,60)) $ map fst lnks + , _rmPS = [] + , _rmBound = rectNSWE 70 10 0 40 + } + where lnks = [((-30,60),pi/2) + ,(( 30,60),-pi/2) + ,((0,10),pi) + ] +roomC :: Float -> Float -> Room +roomC x y = Room + { _rmPolys = [rectNSWE y 0 0 x] + , _rmLinks = lnks + , _rmPath = [] + , _rmPS = [PS (0,0) 0 $ PutWindowBlock (x/2,0) (x/2,y-60) + ] + --, _rmBound = rectNSWE y 0 0 x + , _rmBound = [] + } + where lnks = [( (x-20, 0),pi) + ,( ( 20, 0),pi) + ,( ( 0, 20),pi/2) + ] + +makeRect :: Float -> Float -> [(Point2,Point2)] +makeRect x y = [((0,0),(x,0)) + ,((0,0),(0,y)) + ,((x,y),(x,0)) + ,((x,y),(0,y)) + ] + +gridPoints :: Float -> Int -> Float -> Int -> [Point2] +gridPoints x nx y ny = [(a,b) | a <- take nx $ scanl (+) 0 $ repeat x + , b <- take ny $ scanl (+) 0 $ repeat y + ] + +makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)] +makeGrid x nx y ny = nub $ concatMap doublePair + $ concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y) + $ gridPoints x nx y ny + +roomPadCut :: [Point2] -> Point2 -> Room +roomPadCut ps p = Room + { _rmPolys = [ps] + , _rmLinks = [(p,0),((0,0),pi)] + , _rmPath = [((0,0),p)] + , _rmPS = [] + , _rmBound = [] + } + +roomRect' :: Float -> Float -> Int -> Int -> Room +roomRect' x y a b = Room + { _rmPolys = [rectNSWE y 0 0 x ] + , _rmLinks = lnks + , _rmPath = concatMap doublePair pth + , _rmPS = [PS (x/2,y/2) 0 $ basicLS] + , _rmBound = rectNSWE (y+5) (-5) (-5) (x+5) + } + where yn,xn :: Int + yn = b + yd = (y - 40) / fromIntegral yn + xn = a + xd = (x - 40) / fromIntegral xn + elnks = flip zip (repeat ( pi/2)) $ translateS (0,20) $ gridPoints 0 1 yd (yn+1) + wlnks = flip zip (repeat (-pi/2)) $ translateS (x,20) $ gridPoints 0 1 yd (yn+1) + nlnks = flip zip (repeat ( 0)) $ translateS (20,y) $ gridPoints xd (xn+1) 0 1 + slnks = flip zip (repeat ( pi)) $ translateS (20,0) $ gridPoints xd (xn+1) 0 1 + lnks = nlnks ++ elnks ++ wlnks ++ slnks + pth = linksAndPath lnks $ translateS (20,20) (makeGrid xd xn yd yn) + +roomRect :: Float -> Float -> Room +roomRect x y = roomRect' x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60) + +linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)] +linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks + where linkClosest (p,_) = doublePair (p, head $ sortBy (compare `on` dist p) $ map fst subpth) + +door :: Room +door = Room + { _rmPolys = [rectNSWE 30 0 0 40] + , _rmLinks = lnks + , _rmPath = [((20,25),(20,5))] + , _rmPS = [PS (0,15) 0 $ PutAutoDoor (0,0) (40,0)] + , _rmBound = [] + } + where lnks = [((20,25),0) + ,((20, 5),pi) + ] +roomPillars :: Room +roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect' 240 240 2 2 + where plmnts = g 180 150 90 60 + f a x b y = putBlockRect a x b y + -- putWallBlocks (a,b) (a,y) + -- ++ putWallBlocks (a,y) (x,y) + -- ++ putWallBlocks (x,y) (x,b) + -- ++ putWallBlocks (x,b) (a,b) + g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d + + +putBlockRect a x b y = putWallBlocks (a,b) (a,y) + ++ putWallBlocks (a,y) (x,y) + ++ putWallBlocks (x,y) (x,b) + ++ putWallBlocks (x,b) (a,b) +putBlockV a x b y = putWallBlocks (a,b) (a,y) + ++ putWallBlocks (x,b) (a,b) +putBlockC a x b y = putWallBlocks (a,b) (a,y) + ++ putWallBlocks (x,b) (a,b) + ++ putWallBlocks (a,y) (x,y) +putBlockN a x b y = putWallBlocks (a,b) (a,y) + ++ putWallBlocks (x,b) (a,b) + ++ putWallBlocks (x,y) (x,b) + +branchWith :: Room -> [Tree Room] -> Tree (Either Room Room) +branchWith r ts = Node (Left r) $ [return $ Right door] ++ fmap (fmap Left) ts + +glassSwitchBack :: RandomGen g => State g Room +glassSwitchBack = do + wth <- state $ randomR (200,400) + hgt <- state $ randomR (400,600) + wllen <- state $ randomR (60,wth/2-40) + let hf = hgt/5 + let plmnts = [PS (0,0) 0 $ PutWindowBlock (wth-60, hf) (wllen,hf) + ,PS (0,0) 0 $ PutWindowBlock (wth-wllen,2*hf) (60, 2*hf) + ,PS (0,0) 0 $ PutWindowBlock (wth-60, 3*hf) (wllen,3*hf) + ,PS (0,0) 0 $ PutWindowBlock (wth-wllen,4*hf) (60, 4*hf) + ] + ++ putWallBlocks ( 0, 1*hf) (wllen,1*hf) + ++ putWallBlocks (wth-wllen, 2*hf) ( wth,2*hf) + ++ putWallBlocks ( 0, 3*hf) (wllen,3*hf) + ++ putWallBlocks (wth-wllen, 4*hf) ( wth,4*hf) + return $ set rmPS plmnts $ roomRect' wth hgt 2 6 + +manyDoors :: Int -> Tree (Either Room Room) +manyDoors i = treePost (replicate i (Left door)) $ Right door + +glassLesson :: RandomGen g => State g (Tree (Either Room Room)) +glassLesson = do + corridors <- sequence $ replicate 3 $ fmap Left $ randLinks corridor + return $ Node (Left $ botRoom) [deadRoom door,uppers, treePost (Left door : corridors) $ Right door] + where uppers = Node (Left door) [deadRoom topRoom] + botRoom = set rmPS botplmnts + $ roomRect' 200 200 1 1 + topRoom = set rmPS topplmnts + $ roomRect' 200 200 1 1 + botplmnts = [PS (0,0) 0 $ PutWindow (rectNSWE (200) 0 (90) (110)) + $ withAlpha 0.5 aquamarine + ,PS (50,100) 0 $ PutCrit miniGunCrit + ] + topplmnts = [PS (0,0) 0 $ PutWindowBlock (100,200) (100,0) + ,PS (50,100) 0 $ PutCrit miniGunCrit + ] + +miniRoom1 :: RandomGen g => State g Room +miniRoom1 = do + wth <- state $ randomR (200,400) + hgt <- state $ randomR (400,600) + wllen <- state $ randomR (60,wth/2-40) + let hf = hgt/5 + cry <- randomRanges [--50+2*hf,30+3*hf + 50+3*hf,30+4*hf + ,50+4*hf,30+5*hf + ] + crx <- state $ randomR (wllen,wth-(wllen+40)) + let plmnts = [PS (0,0) 0 $ PutWindowBlock (wth-60, 40+hf) (wllen,40+hf) + ,PS (0,0) 0 $ PutWindowBlock (wth-wllen,40+2*hf) (60,40+2*hf) + ,PS (0,0) 0 $ PutWindowBlock (wth-60, 40+3*hf) (wllen,40+3*hf) + ,PS (0,0) 0 $ PutWindowBlock (wth-wllen,40+4*hf) (60,40+4*hf) + ,PS (crx,cry) 0 $ PutCrit miniGunCrit + ,PS (wth-20,hgt/2+40) 0 $ randC + ] + ++ putWallBlocks ( 0, 40+1*hf) (wllen,40+1*hf) + ++ putWallBlocks (wth-wllen, 40+2*hf) ( wth,40+2*hf) + ++ putWallBlocks ( 0, 40+3*hf) (wllen,40+3*hf) + ++ putWallBlocks (wth-wllen, 40+4*hf) ( wth,40+4*hf) + return $ set rmPS plmnts $ shiftRoomBy ((0,40),0) $ roomRect' wth hgt 2 4 + +miniTree2 :: RandomGen g => State g (Tree (Either Room Room)) +miniTree2 = miniRoom1 >>= randLinks >>= changeLinkTo (\p -> (snd . fst) p < 70) + >>= return . flip branchWith (replicate 3 $ treePost [door,corridor] + critInDeadEnd ) + +miniRoom3 :: RandomGen g => State g (Tree (Either Room Room)) +miniRoom3 = do + w <- state $ randomR (300,400) + h <- state $ randomR (300,400) + let l = -70 + let r = 70 + let cp = (0,h/2+40) + let f = rot90Around cp + let f2 = f . f + let f3 = f . f .f + let cpa p = p +.+ cp + let bl = putWallBlocks (cpa (-20,-40)) (cpa (-20,-80)) + let br = putWallBlocks (cpa (20,-40)) (cpa (20,-80)) + let bm = putWallBlocks (cpa (25,-35)) (cpa (35,-25)) + let b = PutBlock [5,20,20] (greyN 0.5) [(-10,-60) + ,( 10,-60) + ,( 10,-80) + ,(-10,-80) + ] + let plmnts = [PS cp 0 $ PutCrit miniGunCrit + ,PS cp 0 $ PutWindowBlock (0,-40) (0,-80) + ,PS cp (1*pi/4) $ PutWindowBlock (0,-40) (0,-80) + ,PS cp (2*pi/4) $ PutWindowBlock (0,-40) (0,-80) + ,PS cp (3*pi/4) $ PutWindowBlock (0,-40) (0,-80) + ,PS cp (4*pi/4) $ PutWindowBlock (0,-40) (0,-80) + ,PS cp (5*pi/4) $ PutWindowBlock (0,-40) (0,-80) + ,PS cp (6*pi/4) $ PutWindowBlock (0,-40) (0,-80) + ,PS cp (7*pi/4) $ PutWindowBlock (0,-40) (0,-80) + ,PS cp (pi/8) b + ,PS cp (pi/8+1*pi/4) b + ,PS cp (pi/8+2*pi/4) b + ,PS cp (pi/8+3*pi/4) b + ,PS cp (pi/8+4*pi/4) b + ,PS cp (pi/8+5*pi/4) b + ,PS cp (pi/8+6*pi/4) b + ,PS cp (pi/8+7*pi/4) b + ] + randomiseLinks $ set rmPS plmnts $ roomRect w h + +rot90Around :: Point2 -> Point2 -> Point2 +rot90Around cen p = cen +.+ vNormal (p -.- cen) + +-- So, the idea is to attach outer children to the bottommost right nodes +-- inside an inner tree +roomMiniIntro :: RandomGen g => State g (Tree (Either Room Room)) +roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treePost + [return $ connectRoom door + ,join $ takeOne [miniTree2,glassLesson] +-- ,join $ takeOne [miniRoom1] + ] + $ randomiseLinks corridor + where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs + f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs + g (Node (Right x) []) = Node (Right x) [] + g (Node (Right x) xs) = Node (Left x) $ map g xs + g (Node y ys) = Node y $ map g ys + + +putWallBlocks :: Point2 -> Point2 -> [PlacementSpot] +putWallBlocks a b = map (\p -> PS p rot $ PutBlock [5,20,20] (greyN 0.5) + $ reverse $ rectNSWE 10 (-10) (-10) 10) + ps + where d = dist a b + rot = argV (b -.- a) + numPoints' = floor (d / 20) + numPoints = numPoints'*2 + 1 + ns = take (numPoints + 1) [0..] + ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a)) + $ map fromIntegral ns + +roomCenterPillar :: RandomGen g => State g Room +roomCenterPillar = changeLinkTo ((\p -> dist p (120,0) < 10) . fst) + $ set rmPS plmnts $ roomRect' 240 240 2 2 + where plmnts = putWallBlocks (110,110) (110,130) + ++ putWallBlocks (130,110) (130,130) + +roomOctogon :: Room +roomOctogon = Room + { _rmPolys = [[(-20,40),(20,40),(50,70),(50,110),(20,140),(-20,140),(-50,110),(-50,70)] + ] + , _rmLinks = lnks + , _rmPath = allPairs $ map fst lnks + , _rmPS = [] + , _rmBound = [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] + } + where lnks = [((0,140),0) + ,((35,125),0-pi/4) + ,((-35,125),pi/4) + ,( (50,90),0-pi/2) + ,( (-50,90),pi/2) + ,((35,55),0-3*pi/4) + ,((-35,55),3*pi/4) + ,( (0,40),pi) + ] + +randomCorridorFrom :: RandomGen g => [a] -> State g (Tree (Either a a)) +randomCorridorFrom xs = do + rooms <- sequence $ replicate 5 $ takeOne xs + return $ treeTrunk (map Left $ init rooms) (Node (Right (last rooms)) []) + + + +--splitWall :: Float -> Wall -> [[Point]] +--splitWall x wl = + +sWalls g = wallsFromTree $ evalState (iterateWhile boundClip lev1) $ g + + +randFirstWeapon :: State StdGen PSType +randFirstWeapon = do + r <- state $ randomR (-pi,pi) + takeOne $ map PutFlIt + [ basicFlIt {_flItRot=r,_flIt = pistol} + , basicFlIt {_flItRot=r,_flIt = ltAutoGun} +-- , basicFlIt {_flItRot=r,_flIt = autoGun} + , basicFlIt {_flItRot=r,_flIt = spreadGun} + , basicFlIt {_flItRot=r,_flIt = multGun} + , basicFlIt {_flItRot=r,_flIt = launcher} +-- , basicFlIt {_flItRot=r,_flIt = lasGun} +-- , basicFlIt {_flItRot=r,_flIt = flamer} + ] + +--randC1 :: State StdGen PSType +randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit) + +randC = randC1 + +-- randSwarmCrit = RandPS $ takeOne $ map PutCrit $ (armouredSwarmCrit : replicate 100 swarmCrit) + +weaponEmptyRoom :: RandomGen g => State g (Tree (Either Room Room)) +weaponEmptyRoom = do + w <- state $ randomR (220,300) + h <- state $ randomR (220,300) + let plmnts = [PS (w/2,h-40) 0 $ RandPS randFirstWeapon + ,PS (20,20) (pi/2) $ randC1 + ,PS (w-20,20) (pi/2) $ randC1 + ] + randomiseLinks =<< (changeLinkTo ((\p -> dist p (w/2,0) < 10) . fst) + $ set rmPS plmnts $ roomRect' w h 2 2) + + +--weaponUnderCrits :: RandomGen g => State g (Tree (Either Room Room)) +--weaponUnderCrits = do +-- let plmnts = [PS (0,0) 0 $ RandPS randFirstWeapon +-- ,PS (-5,0) (0-pi/2) $ randC1 +-- ,PS (5,20) (0-pi/2) $ randC1 +-- ] +-- let continuationRoom = treeTrunk [Left corridorN,Left corridorN] +-- (connectRoom (set rmPS plmnts $ corridorN)) +-- deadEndRoom <- takeOne [roomSquare,roomPillars,roomVs,roomCenterPillar] +-- junctionRoom <- takeOne [Left corridorE,Left corridorW] +-- return $ treeTrunk [Left corridorN,Left corridorN] +-- $ Node junctionRoom +-- [continuationRoom +-- ,deadRoom deadEndRoom +-- ] + + +weaponBehindPillar :: RandomGen g => State g (Tree (Either Room Room)) +weaponBehindPillar = do + crPos <- takeOne $ [(x,y) | x <- [20,220], y <- [20,220]] ++ [(120,160),(120,200)] + let d p = argV $ (120,80) -.- p + let plmnts1 = [PS (120,160) 0 $ RandPS randFirstWeapon + ,PS crPos (d crPos) $ randC1 + ] + rcp <- roomCenterPillar + return $ treeTrunk [Left door + ,Left $ over rmLinks tail $ over rmPS (++ plmnts1) rcp] + (connectRoom $ set rmPS [PS (20,60) (0-pi/2) $ randC1] + $ corridorN) + +weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room)) +weaponBetweenPillars = do + wpPos <- takeOne [(x,y) | x <- [20,120,220], y <- [20,120,220]] + (ps,_) <- takeNMore 2 ([], [(x,y) | x <- [20,220], y <- [20,120,220]]) + let crPos1 = ps !! 0 + let crPos2 = ps !! 1 + let d p = argV $ (120,120) -.- p + let plmnts = [PS wpPos 0 $ RandPS randFirstWeapon + ,PS crPos1 (d crPos1) $ randC1 + ,PS crPos2 (d crPos2) $ randC1 + ] + randomiseLinks =<< (filterLinks f $ over rmPS (++plmnts) $ roomPillars) + where f (_,a) = a == 0 + +blockedCorridor :: RandomGen g => State g (Tree (Either Room Room)) +blockedCorridor = do + r <- state $ randomR (0,pi) + n <- state $ randomR (0,3) + let plmnts = [PS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256) + $ reverse $ rectNSWE 10 (-10) (-10) 10 + ] + sequence $ treePost (replicate n $ fmap Left $ randLinks corridor) + $ fmap Right $ return $ set rmPS plmnts corridor + +-- weaponBehindV :: RandomGen g => State g (Tree (Either Room Room)) +-- weaponBehindV = do +-- wpPos <- takeOne [(x,y) | x <- [70,-70], y <- [90,230]] +-- (ps,_) <- takeNMore 2 ([], [(x,y) | x <- [60,-60], y <- [100,220]]) +-- r <- state $ randomR (0,pi) +-- let crPos1 = ps !! 0 +-- let crPos2 = ps !! 1 +-- let d p = argV $ (0,160) -.- p +-- let plmnts = [PS wpPos 0 $ RandPS randFirstWeapon +-- ,PS crPos1 (d crPos1) $ randC1 +-- ,PS crPos2 (d crPos2) $ randC1 +-- ,PS (0,295) r $ PutBlock [5,5,5] (makeColorI 150 75 0 250) +-- $ reverse $ rectNSWE 10 (-10) (-10) 10 +-- ] +-- return $ connectRoom $ set rmPS plmnts $ roomVs + +weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room)) +weaponLongCorridor = do + root <- takeOne $ [tEast, tWest] + connectingRoom <- takeOne [tEast,tWest] + i1 <- state $ randomR (2,5) + i2 <- state $ randomR (2,5) + let branch1 = treeTrunk (replicate i1 $ Left corridor) (connectRoom $ putCrs connectingRoom) + let branch2 = treeTrunk (replicate i2 $ Left corridor) (deadRoom $ putWp corridorN) + return $ Node (Left root) [branch1,branch2] + where putCrs = set rmPS [PS (10,40) (-pi/2) $ randC + ,PS (-10,40) (-pi/2) $ randC + ] + putWp = set rmPS [PS (20,40) 0 $ RandPS randFirstWeapon] + +critInDeadEnd :: Room +critInDeadEnd = set rmPS [PS (0,0) 0 $ randC] deadEndRoom + +deadEndRoom :: Room +deadEndRoom = Room + { _rmPolys = [rectNSWE 40 (-20) (-20) 20 + ] + , _rmLinks = lnks + , _rmPath = [] + , _rmPS = [] + , _rmBound = rectNSWE 20 (-20) (-30) 30 + } + where lnks = [((0,30) ,0) + ] + + +weaponRoom :: RandomGen g => State g (Tree (Either Room Room)) +weaponRoom = do + x <- takeOne [weaponEmptyRoom + --, weaponUnderCrits + , weaponBehindPillar + , weaponBetweenPillars + , weaponLongCorridor + ] + x + +roomCCrits :: RandomGen g => State g (Tree (Either Room Room)) +roomCCrits = do + ps <- sequence $ replicate 25 $ randInCirc 9 + let plmnts = map (\p -> PS p 0 $ randC) + $ zipWith (+.+) [(x,y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps + return $ connectRoom $ over rmPS (++plmnts) $ roomC 200 200 + +-- +-- roomSwarm :: RandomGen g => State g (Tree (Either Room Room)) +-- roomSwarm = do +-- ps <- sequence $ replicate 25 $ randInCirc 200 +-- let plmnts = map (\p -> PS ((500,500) +.+ p) 0 $ PutCrit swarmCrit) ps +-- return $ connectRoom $ set rmPS plmnts $ roomRect 1000 1000 +-- + + +roomToLevel2 :: RandomGen g => State g (Tree (Either Room Room)) +roomToLevel2 = join $ takeOne + [ portalRoom1 + ] + +portalRoom1 :: RandomGen g => State g (Tree (Either Room Room)) +portalRoom1 = return $ connectRoom $ (roomRect 300 300) { _rmPS = plmnts} + where plmnts = [PS (0,0) (0-pi/2) $ PutPressPlate (levelPortalAt (200,120) 1) + ,PS (60,100) pi $ PutCrit autoCrit + ] + + + +branchRectWith :: RandomGen g => State g (Tree (Either Room Room)) -> State g (Tree (Either Room Room)) +branchRectWith t = do + x <- state $ randomR (100,200) + y <- state $ randomR (100,200) + b <- t + root <- randLinks $ roomRect x y + return $ Node (Left root) [Node (Right door) [], fmap rToL $ treeTrunk [Left door] b] + where rToL :: Either a a -> Either a a + rToL (Right r) = Left r + rToL (Left r) = Left r + +slowDoorRoom :: RandomGen g => State g (Tree (Either Room Room)) +slowDoorRoom = do + x <- state $ randomR (400,800) + y <- state $ randomR (400,800) + h <- state $ randomR (200,min (y-100) 500) + (butPos,butRot) <- takeOne [( (x/2-50,5),0) + ,( (x/2+50,5),0) + ] + let n = 25 + xs <- sequence $ replicate n $ state $ randomR (10,x-10) + ys <- sequence $ replicate n $ state $ randomR (h+20,y) + rs <- sequence $ replicate n $ state $ randomR (0,2*pi) + let ps = zip xs ys + xs' <- sequence $ replicate 5 $ state $ randomR (10,x-10) + ys' <- sequence $ replicate 5 $ state $ randomR (h+20,y) + let crits = zipWith (\p r -> PS p r randC1) ps rs + let barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys' + let pillarsa = [] + let pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20) + ++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20) + ++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20) + ++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20) + let pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20) + ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20) + pillars <- takeOne [pillarsa, pillarsb, pillarsc] + let cond x = (snd . fst) x > h + 40 + let cond2 x = (snd . fst) x < h - 40 + but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h) + -- ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h) + ] + fmap connectRoom (filterLinks cond =<< (changeLinkTo cond2 + $ set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels) + $ roomRect x y + )) +longRoom :: RandomGen g => State g Room +longRoom = do + h <- state $ randomR (1500,1500) + let w = 75 + let cond x = (snd . fst) x < h - 40 + -- let solidBlocks = putWallBlocks (12.5,h-25) (12.5,h-265) + -- ++putWallBlocks (37.5,h-25) (37.5,h-265) + -- ++putWallBlocks (62.5,h-25) (62.5,h-265) + -- ++putWallBlocks (87.5,h-25) (87.5,h-265) + -- let wBlocks = [PS (0,0) 0 $ PutWindowBlock (12.5,h-50) (12.5,h-265) + -- ,PS (0,0) 0 $ PutWindowBlock (37.5,h-50) (37.5,h-265) + -- ,PS (0,0) 0 $ PutWindowBlock (62.5,h-50) (62.5,h-265) + -- ,PS (0,0) 0 $ PutWindowBlock (87.5,h-50) (87.5,h-265) + -- ] + let ws = map (\ps -> PS (0,0) 0 $ PutWindow ps $ withAlpha 0.5 aquamarine) + [rectNSWE (h-35) (h-135) (-10) 10 + ,rectNSWE (h-35) (h-135) 15 35 + ,rectNSWE (h-35) (h-135) 40 60 + ,rectNSWE (h-35) (h-135) 65 85 + ] + let wsDefense = map (\ps -> PS (0,0) 0 $ PutWindow ps $ withAlpha 0.5 aquamarine) + [rectNSWE (95) (70) 0 25 + ,rectNSWE (95) (70) 50 75 + ] + brls <- fmap (map (\p -> PS (p +.+ (10,200)) 0 $ PutCrit explosiveBarrel) ) + $ sequence $ replicate 5 $ randInRect (w-20) 900 + let rm = roomRect' w (h+70) 1 1 & rmPolys %~ ( (++) + [rectNSWE h (h-165) (-45) (w+45) + ] + ) + changeLinkTo cond $ set rmPS (ws ++ brls ++ wsDefense ++ + [PS ( 12.5,h-25) 0 $ PutCrit longCrit + ,PS ( 37.5,h-25) 0 $ PutCrit longCrit + ,PS ( 62.5,h-25) 0 $ PutCrit longCrit + ] + ) + $ rm + + +shooterRoom :: RandomGen g => State g Room +shooterRoom = do + h <- state $ randomR (200,300) + let cond x = (snd . fst) x < h - 40 + changeLinkTo cond $ set rmPS ( putWallBlocks (50,50) (50,h) ++ + [PS ( 25,h-25) 0 $ PutCrit $ addArmour autoCrit + ,PS ( 75,h-30) 0 $ PutCrit explosiveBarrel + ,PS ( 75,h-60) 0 $ PutCrit explosiveBarrel + ,PS ( 85,h-10) 0 $ PutCrit explosiveBarrel + ,PS ( 85,h-45) 0 $ PutCrit explosiveBarrel + ] + ) + $ roomRect' 100 h 1 1 + + +shootersRoom1 :: RandomGen g => State g Room +shootersRoom1 = do + w <- state $ randomR (200,300) + x1 <- state $ randomR (20,w/3-20) + x2 <- state $ randomR (w/3+20,2*w/3-20) + x3 <- state $ randomR (2*w/3+20,w-20) + y1 <- state $ randomR (250,560) + y2 <- state $ randomR (250,560) + y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560) + x4 <- state $ randomR (60,w-60) + y4 <- state $ randomR (40,180) + p <- takeOne [(x1,y1-10),(x2,y2-10),(x3,y3-10)] + let bln x y = putBlockN (x+25) (x-25) (y+10) (y) + let blv x y = putBlockV (x+25) (x-25) (y+10) (y) + let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4 + ++ [PS p (-pi/2) $ PutCrit autoCrit + ] + return $ set rmPS plmnts $ roomRect w 600 + +shootersRoom :: RandomGen g => State g Room +shootersRoom = do + w <- state $ randomR (200,300) + x1 <- state $ randomR (20,w/3-20) + x2 <- state $ randomR (w/3+20,2*w/3-20) + x3 <- state $ randomR (2*w/3+20,w-20) + y1 <- state $ randomR (250,560) + y2 <- state $ randomR (250,560) + y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560) + x4 <- state $ randomR (60,w-60) + y4 <- state $ randomR (40,180) + let bln x y = putBlockN (x+25) (x-25) (y+10) (y) + let blv x y = putBlockV (x+25) (x-25) (y+10) (y) + let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4 + ++ [PS (x1,y1-10) (-pi/2) $ PutCrit autoCrit + ,PS (x2,y2-10) (-pi/2) $ PutCrit autoCrit + ,PS (x3,y3-10) (-pi/2) $ PutCrit autoCrit + ] + return $ set rmPS plmnts $ roomRect w 600 + +pistolerRoom :: RandomGen g => State g Room +pistolerRoom = do + let f2 x y = putWallBlocks (x,y) (x,y) +-- let f2 x y = [PS (x,y) 0 $ PutWindow (rectNSEW 40 0 0 40) $ withAlpha 0.5 aquamarine] + f3 x y = putWallBlocks (x-20,y) (x+20,y) + ++ putWallBlocks (x,y-20) (x,y+20) + f4 x y = putWallBlocks (x-20,y-20) (x+20,y+20) + ++ putWallBlocks (x+20,y-20) (x-20,y+20) + --f <- takeOne [f2,f3,f4] + f <- takeOne [f2] + h <- state $ randomR (400,800) + let w = h + i <- takeOne [2,4,6,8] + let j = fromIntegral (i+1) + -- the 20+etc here is to correct for the pathfinding grid, which matches up to + -- edges based on the size of doors (i.e. the line next to the wall is 20 + -- away from it) + xs = take i [20+0.5*(w-40)/(j-1),20+1.5*(w-40)/(j-1)..] + ys = take i [20+0.5*(h-40)/(j-1),20+1.5*(h-40)/(j-1)..] + gap = 0.5 * h / j + ps <- takeN 3 $ zip (map (+gap) xs) ys + aa <- state $ randomR (0,2*pi) + ab <- state $ randomR (0,2*pi) + ac <- state $ randomR (0,2*pi) + let plmnts = [PS (ps !! 0) aa $ PutCrit pistolCrit + ,PS (ps !! 1) ab $ PutCrit pistolCrit + ,PS (ps !! 2) ac $ PutCrit pistolCrit + -- ,PS (w-5,h/2) 0 $ basicLS + -- ,PS (5,h/2) 0 $ basicLS + -- ,PS (w/2,h-5) 0 $ basicLS + -- ,PS (w/2,5) 0 $ basicLS + -- ,PS (w-50,h/2) 0 $ basicLS + -- ,PS (50,h/2) 0 $ basicLS + ,PS (w/2,h-50) 0 $ basicLS + ,PS (w/2,50) 0 $ basicLS + ,PS (w-5,h-5) 0 $ basicLS + ,PS (5,h-5) 0 $ basicLS + ,PS (w-5,5) 0 $ basicLS + ,PS (5,5) 0 $ basicLS + ,PS (w/2,h/2) 0 $ basicLS + ] + ++ + -- f (w*0.25) (h*0.5) + concat [f x y | x<-xs,y<-ys] + return + $ set rmPS plmnts $ roomRect' w h (max i 2) (max i 2) + +shootingRange :: RandomGen g => State g (Tree (Either Room Room)) +shootingRange = do + rm1 <- shootersRoom1 >>= changeLinkTo (\((_,y),_) -> y < 40) + >>= filterLinks (\((_,y),r) -> y > 200 && r /= 0) + rm2 <- shootersRoom >>= changeLinkTo (\((x,y),_) -> y < 10 && x > 20 && x < 180) + >>= filterLinks (\((_,y),r) -> y > 200 && r /= 0) + rm3 <- shootersRoom >>= changeLinkTo (\((x,y),_) -> y < 10 && x > 20 && x < 180) + >>= filterLinks (\(_,r) -> r == 0) + return $ treePost [Left rm1 + ,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20) + ,Left rm2 + ,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20) + ] + (Right rm3) + + +spawnerRoom :: RandomGen g => State g (Tree (Either Room Room)) +spawnerRoom = do + x <- state $ randomR (250,300) + y <- state $ randomR (300,400) + wl <- takeOne [PS (0,0) 0 $ PutWindow (rectNSWE (y-60) 0 (x/2-10) (x/2+10)) + $ withAlpha 0.5 aquamarine + ,PS (0,0) 0 $ PutWindowBlock (x/2,0) (x/2,y-60) + ] + let plmnts = [PS (x/4, y/4) (pi/2) $ PutCrit spawnerCrit + -- ,PS (0,0) 0 $ PutWindowBlock (x/2,0) (x/2,y-60) + ,wl + ] + let f ((lx,_),_) = lx < x/2-5 + roomWithSpawner <- randomiseLinks =<< (filterLinks f $ set rmPS plmnts $ roomRect' x y 2 2) + return $ treeTrunk [Left (airlock 0)] roomWithSpawner diff --git a/src/Dodge/Smoke.hs b/src/Dodge/Smoke.hs new file mode 100644 index 000000000..b1a23a8dd --- /dev/null +++ b/src/Dodge/Smoke.hs @@ -0,0 +1,33 @@ +module Dodge.Smoke where + +import Dodge.Data +import Dodge.Base +import Dodge.RandomHelp +import Geometry.Data +import Picture + +import Control.Lens +import Control.Monad.State + +spawnSmokeAt :: Point2 -> World -> World +spawnSmokeAt p w = + w & smoke %~ (:) thesmoke + & randGen .~ g + where + thesmoke = Smoke + {_smPos = p + ,_smRad = 20 + ,_smColor = white + ,_smUpdate = f + ,_smPs = ps + ,_smTime = 500 + } + f s = case s ^. smPs of + [] -> Nothing + _ -> case s ^. smTime of + 0 -> Just $ s & smPs %~ init + t -> Just $ s & smTime .~ t-1 + (ps,g) = runState (sequence $ replicate 60 $ randInCirc 20) $ _randGen w + +spawnSmokeAtCursor :: World -> World +spawnSmokeAtCursor w = spawnSmokeAt (mouseWorldPos w) w diff --git a/src/Dodge/SoundLogic.hs b/src/Dodge/SoundLogic.hs new file mode 100644 index 000000000..44c51b031 --- /dev/null +++ b/src/Dodge/SoundLogic.hs @@ -0,0 +1,86 @@ +module Dodge.SoundLogic where +-- imports {{{ +import Dodge.Data + +import Control.Lens +import qualified Data.Map as M +-- }}} +-- +-- PLACEHOLDERS: + +haltSound :: World -> World +haltSound w = w + +pauseSound :: World -> World +pauseSound w = w + +resumeSound :: World -> World +resumeSound w = w + +soundOnce :: Int -> World -> World +soundOnce i = over soundQueue ((:) i) + +continueSoundFrom :: SoundOrigin -> Int -> Int -> Int -> World -> World +continueSoundFrom so sType time fadeTime w + = over sounds (M.insertWith f so sound) w + where sound = Sound { _soundType = sType + , _soundTime = time + , _soundFadeTime = fadeTime + , _soundChannel = Nothing + , _soundPos = Nothing + } + f _ s = s {_soundTime = time, _soundFadeTime = fadeTime} + +soundFrom :: SoundOrigin -> Int -> Int -> Int -> World -> World +soundFrom so sType time fadeTime w + = over sounds (M.insertWith f so sound) w + where sound = Sound { _soundType = sType + , _soundTime = time + , _soundFadeTime = fadeTime + , _soundChannel = Nothing + , _soundPos = Nothing + } + f _ s = s {_soundTime = time, _soundFadeTime = fadeTime} + +soundMultiFrom :: [SoundOrigin] -> Int -> Int -> Int -> World -> World +soundMultiFrom [] _ _ _ w = w +soundMultiFrom (so:sos) sType time fadeTime w + | so `M.member` _sounds w = soundMultiFrom sos sType time fadeTime w + | otherwise = over sounds (M.insert so sound) w + where sound = Sound { _soundType = sType + , _soundTime = time + , _soundFadeTime = fadeTime + , _soundChannel = Nothing + , _soundPos = Nothing + } + +stopSoundFrom :: SoundOrigin -> World -> World +stopSoundFrom so = over (sounds . ix so . soundTime) (min 0) + + +-- idea: pass the id of the sound to the world and send it to some queue for +-- playback + +reloadSound,putDownSound,pickUpSound,fireSound,grenadeBang,healSound,teleSound,twoStepSlowSound :: Int +clickSound = 1 +reloadSound = 2 +pickUpSound = 4 +putDownSound = 5 +fireSound = 6 +grenadeBang = 7 +tapQuiet = 8 +twoStepSound = 9 +healSound = 10 +doorSound = 11 +twoStepSlowSound = 12 +knifeSound = 13 +buzzSound = 14 +hitSound = 15 +autoGunSound = 16 +shotgunSound = 17 +teleSound = 18 +longGunSound = 19 +launcherSound = 20 +smokeTrailSound = 21 +foot1Sound = 22 +foot2Sound = 23 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs new file mode 100644 index 000000000..88483c315 --- /dev/null +++ b/src/Dodge/Update.hs @@ -0,0 +1,190 @@ +module Dodge.Update where +-- imports {{{ +import Dodge.Data +import Dodge.Base +import Dodge.WallCreatureCollisions +import Dodge.Block +import Dodge.Camera +import Dodge.SoundLogic + +import Geometry + +import Data.List +import Data.Maybe +import Data.Function +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import qualified Data.Map as M + +import Control.Lens + + +-- }}} + +update :: World -> World +update w = let w1 = updateParticles' $ updateParticles + $ updateLightSources + $ zoneClouds + $ updateClouds + $ updateSmoke + $ updateCreatures + $ updateBlocks -- $ zoning + $ updateSeenWalls + w + w2 = -- updateWeaponCounters $ + simpleCrSprings + $ zoneCreatures $ wallEvents + $ set worldEvents id $ _worldEvents w1 + w1 + w3 = updateCamera + $ updateAfterParticles' + $ colCrsWalls + w2 + in checkEndGame $ ppEvents w3 + where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) + -- w + -- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize + -- = insertIMInZone x y wlid wl + -- | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips + -- where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1)) + -- wlid = _wlID wl + -- ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1) + zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w)) + creatureInZone cr = insertIMInZone x y cid cr + where (x,y) = zoneOfPoint $ _crPos cr + cid = _crID cr + zoneClouds = set cloudsZone (IM.foldr cloudInZone IM.empty (_clouds w)) + cloudInZone cr = insertIMInZone x y cid cr + where (x,y) = zoneOfPoint $ _clPos cr + cid = _clID cr + +updateLightSources w = set tempLightSources (catMaybes tlss) w' + where (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w + +updateParticles w = IM.foldr' _ptUpdate w $ _particles w + +updateSmoke :: World -> World +updateSmoke w = w & smoke %~ mapMaybe (\s -> _smUpdate s s) + +updateParticles' :: World -> World +updateParticles' w = set particles' (catMaybes ps) w' + where (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles' w + +updateAfterParticles' :: World -> World +updateAfterParticles' w = set afterParticles' (catMaybes ps) w' + where (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _afterParticles' w + +updateCreatures :: World -> World +updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w + where ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w + + +wallEvents :: World -> World +wallEvents w = IM.foldr (_doorMech) w ( IM.filter (\d -> case d of + Door {} -> True + AutoDoor {} -> True + BlockAutoDoor {} -> True + _ -> False) ( _walls w)) + +ppEvents :: World -> World +ppEvents w = IM.foldr' (\pp w -> _ppEvent pp pp w) w $ _pressPlates w + +updateSeenWalls :: World -> World +updateSeenWalls w = foldr markSeen w wallsToUpdate + where yPos = _crPos $ _creatures w IM.! 0 + wallsToUpdate = map _wlID $ IM.elems $ wallsNearPoint yPos w +-- wallsToUpdate = concatMap (\p -> collidePointFindWalls yPos (yPos +.+p) $ wallsAlongLine yPos (yPos +.+ p) w) +-- $ nRays 60 + markSeen i = set (walls . ix i . wlSeen) True + +setTestStringIO :: IO World -> IO World +setTestStringIO = fmap (\ w -> set testString (show $ s w) w) + where s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos) + -- w --do numC <- Mix.numChannelsPlaying +-- w' <- w +-- let ycr = _creatures w' IM.! 0 +-- let st = _stance $ _crState ycr +-- let vel = magV $ _crPos ycr -.- _crOldPos ycr +-- let (x,y) = zoneOfPoint $ _crPos ycr +-- --fmap (set testString $ show (map _wlLine $ IM.elems $ _wallsZone w' IM.! x IM.! y)) w +-- fmap (set testString $ show $ last $ show $ pairsToIncidence' $ _pathGraph' w') w + +-- update logic: creature old position set, creatures perform actions including movement, +-- creatures collided with each other, camera updated, particles updated, creatures +-- collided with walls + + +checkEndGame :: World -> World +checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuState = GameOverMenu} + | otherwise = w + +updateClouds :: World -> World +updateClouds w = IM.foldr' updateCloud w $ _clouds w + +updateCloud :: Cloud -> World -> World +updateCloud c w | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c) + | otherwise = moveCloud c w + +moveCloud :: Cloud -> World -> World +moveCloud c w = _clEffect c c . theUpdate $ w + where newVel = 0.99 *.* springVels + springVels = IM.foldr' (clClSpringVel c w) (_clVel c) (cloudsNearPoint oldPos w) + oldPos = _clPos c + newPos = oldPos +.+ newVel + hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w + finalPos = fromMaybe newPos (fmap fst hitWl) + finalVel = fromMaybe newVel (fmap snd hitWl) + theUpdate w' = w' & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1) + & clouds . ix (_clID c) . clVel .~ finalVel + & clouds . ix (_clID c) . clPos .~ finalPos + +clClSpringVel :: Cloud -> World -> Cloud -> Point2 -> Point2 +clClSpringVel a w b v + | ida == idb = v + | dist pa pb < 5 = v +.+ 0.1 *.* (safeNormalizeV (pa -.- pb)) + | otherwise = v + where ida = _clID a + idb = _clID b + pa = _clPos a + pb = _clPos b + +simpleCrSprings :: World -> World +simpleCrSprings w = IM.foldr' crSpring w $ _creatures w + +crSpring :: Creature -> World -> World +crSpring c w = IM.foldr' (crCrSpring c) w $ cs + where cs = creaturesNearPoint (_crPos c) w + +crCrSpring :: Creature -> Creature -> World -> World +crCrSpring c1 c2 w + | id1 == id2 = w + | vec == (0,0) = w + | diff < comRad = over (creatures . ix id1 . crPos) (+.+ overlap1) + $ over (creatures . ix id2 . crPos) (-.- overlap2) w + | otherwise = w + where id1 = _crID c1 + id2 = _crID c2 + vec = _crPos c1 -.- _crPos c2 + diff = magV $ vec + comRad = _crRad c1 + _crRad c2 + overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec + overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec + massT = _crMass c1 + _crMass c2 + +collidePointFindWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Int +collidePointFindWall p1 p2 ws = fmap fst $ listToMaybe $ sortBy f + $ IM.toList + $ IM.mapMaybe ((\(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws + where f (_,a) (_,b) = compare (magV (p1 -.- a)) (magV (p1 -.- b)) + +collidePointFindWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int] +collidePointFindWalls p1 p2 ws + -- = map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fst . fromJust)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws + = map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fromJust . fst)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws + where f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl)) + g (_,wl) = _wlIsSeeThrough wl + takeWhileAnd h xs = let (ys,zs) = span h xs + in ys ++ tf zs + where tf (x:_) = [x] + tf _ = [] + diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs new file mode 100644 index 000000000..4624822aa --- /dev/null +++ b/src/Dodge/WallCreatureCollisions.hs @@ -0,0 +1,95 @@ +module Dodge.WallCreatureCollisions where +-- imports {{{ +import Dodge.Data +import Dodge.Base +import Geometry + +import Data.List +import Data.Maybe +import Data.Function +import Control.Lens +import qualified Data.IntMap.Strict as IM + +colCrsWalls :: World -> World +colCrsWalls w = over creatures (fmap (colCrWall w)) w + +colCrWall :: World -> Creature -> Creature +colCrWall w c = pushOutFromWall w c + +pushOutFromWall :: World -> Creature -> Creature +pushOutFromWall w c + | p1 == p2 = c + | otherwise = over crPos ( + collideCorners rad p1 wallPoints + . + collideWalls rad p1 ls + . checkPushThroughs rad p1 ls + ) + c + where rad = _crRad c + wallBuffer + p1 = _crOldPos c + p2 = _crPos c + ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w + wallPoints = nub $ concat ls + +-- colCrPushThrough :: World -> Creature -> Creature +-- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr +-- where rad = _crRad cr + wallBuffer +-- p1 = _crOldPos cr +-- p2 = _crPos cr +-- ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w +-- -- probably best to push check pushing through walls before creature springs + +-- the amount to push creatures out from walls, extra to their radius +wallBuffer = 3 + +-- the following tests whether a moving circle crosses a list of walls, and +-- places the circle accordingly. +-- It supposes that the circle will only interact with at most two walls. +-- the reverse prevents the collision from happening again with the first wall, +-- when two walls are collided with +collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2 +collideWalls rad cp1 walls cp2 + = case (listToMaybe.mapMaybe (collideWall rad cp1 cp2)) walls of + Nothing -> cp2 + Just cp3 -> case (listToMaybe.reverse.mapMaybe (collideWall rad cp1 cp3)) walls of + Nothing -> cp3 + Just cp4 -> cp4 + +-- assumes that the wall is orientated +-- assumes wall points are different +collideWall :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2) +collideWall rad cp1 cp2 (wp1:wp2:_) + | isOnWall = Just newP -- +.+ (1 *.* norm)) + | otherwise = Nothing + where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2) + wp1' = (rad *.* norm) +.+ wp1 + wp2' = (rad *.* norm) +.+ wp2 + newP = errorClosestPointOnLine 5 wp1' wp2' cp2 + isOnWall = circOnLine' wp1 wp2 cp2 rad + isJust Nothing = False + isJust _ = True + +collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2 +collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps + +-- collide circles with points (outer corners) +intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2 +intersectCirclePoint rad p cCen | dist cCen p > rad = cCen + | otherwise = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p)) + +checkPushThroughs :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2 +checkPushThroughs rad cp1 walls cp2 + = fromMaybe cp2 $ (listToMaybe.mapMaybe (checkPushThrough rad cp1 cp2)) walls + +checkPushThrough :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2) +checkPushThrough rad cp1 cp2 (wp1:wp2:_) + | isPushedThrough = intersectSegSeg' cp1 cp2 wp1 wp2 + | otherwise = Nothing + where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2) + wp1' = (rad *.* norm) +.+ wp1 + wp2' = (rad *.* norm) +.+ wp2 + newP = errorClosestPointOnLine 5 wp1' wp2' cp2 + isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg' cp1 cp2 wp1 wp2) + isJust Nothing = False + isJust _ = True diff --git a/src/Dodge/Weapons.hs b/src/Dodge/Weapons.hs new file mode 100644 index 000000000..746f037a6 --- /dev/null +++ b/src/Dodge/Weapons.hs @@ -0,0 +1,2764 @@ +{-# LANGUAGE BangPatterns #-} +module Dodge.Weapons where +-- imports {{{ +import Dodge.Data +import Dodge.Base +import Dodge.SoundLogic +import Dodge.CreatureActions +import Dodge.RandomHelp +import Dodge.WorldActions +import Dodge.Debug +import Dodge.WallCreatureCollisions +import Dodge.Prototypes + +import Geometry +import Picture + +import Data.List +import Data.Char +import Data.Maybe +import Data.Function +--import Data.Graph.Inductive.Graph +--import Data.Graph.Inductive.PatriciaTree +--import Codec.BMP +import qualified Data.ByteString as B +import Control.Lens +import Control.Applicative +import Control.Monad.State +import Control.Monad +import qualified SDL as SDL +--import qualified Graphics.UI.SDL.Mixer as Mix +import System.Random +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import qualified Data.Map as M + +import Foreign.ForeignPtr +import Control.Concurrent +-- }}} + +pistol,lasGun,tractorGun,launcher,autoGun + ,teslaGun + ,spreadGun + ,multGun +-- ,shatterGun + ,longGun,flamer,blinkGun,forceFieldGun :: Item + +pistol = Weapon + { _itName = "pistol" + , _itIdentity = Pistol + , _wpMaxAmmo = 15 + , _wpLoadedAmmo = 15 + , _wpAmmoType = PistolBullet + , _wpReloadTime = 40 + , _wpReloadState = 0 + , _wpFireRate = 8 + , _wpFireState = 0 + , _wpFire = shootWithSound 0 + $ withAccVelWthHiteff' 0.1 (30,0) 2 +-- $ threeEff' bulIncCr' bulIncWall' bulHitFF' + $ threeEff' bulHitCr' bulHitWall' bulHitFF' + , _wpSpread = 0.02 + , _wpRange = 20 + , _itHammer = HammerUp + , _itFloorPict = onLayer FlItLayer $ color green $ polygon $ rectNESW 3 3 (-3) (-3) + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 1 + , _itAimingRange = 0 + , _itZoom = basicItZoom + , _itEquipPict = drawWeapon $ color green $ polygon $ rectNESW 3 3 (-3) (-3) + , _itScrollUp = const id + , _itScrollDown = const id + , _itAttachment = Nothing + , _itID = Nothing + , _itEffect = wpRecock + , _itInvDisplay = basicWeaponDisplay + , _itInvColor = white + } +defaultGun = pistol +basicWeaponDisplay :: Item -> String +basicWeaponDisplay it = _itName it ++ " " ++ aIfLoaded ++ "/" ++ availableAmmo + where + availableAmmo = show $ _wpMaxAmmo it +-- availableAmmo = if _unlimitedAmmo w +-- then show $ _wpMaxAmmo it +-- else show $ case _crAmmo (you w) M.!? _wpAmmoType it of +-- Nothing -> 0 +-- Just x -> x + aIfLoaded = case (_wpReloadState it) of + 0 -> show $ _wpLoadedAmmo it + x -> "R" ++ show x +effectGun :: String -> (Int -> World -> World) -> Item +effectGun name eff = defaultGun + { _itName = name ++ "Gun" + , _wpFire = eff + } +autoEffectGun :: String -> (Int -> World -> World) -> Item +autoEffectGun name eff = autoGun + { _itName = name ++ "Gun" + , _wpFire = eff + } + +autoGun = defaultGun + { _itName = "autoGun .........." + , _itIdentity = AutoGun + , _wpMaxAmmo = 30 + , _wpLoadedAmmo = 30 + , _wpAmmoType = PistolBullet + , _wpReloadTime = 80 + , _wpReloadState = 0 +-- , _wpFireRate = 6 + , _wpFireRate = 5 + , _wpFireState = 0 + , _wpFire = autoFireMode + , _wpSpread = autogunSpread + , _wpRange = 20 + , _itHammer = NoHammer + , _itFloorPict = onLayer FlItLayer $ color red $ pictures [polygon [(-4,-4),(-4,4),(4,4),(4,-4)]] + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.4 + , _itAimingRange = 1 + , _itZoom = basicItZoom {_itAimZoomFac = 1.5} + , _itEquipPict = drawWeapon $ color red $ polygon $ rectNESW 4 4 (-4) (-4) + , _itEffect = NoItEffect + , _itAttachment = Just $ ItMode 0 + , _itScrollUp = incMode + , _itScrollDown = incMode + } +autoFireMode = shootWithSound (fromIntegral autoGunSound) + $ withRecoil 40 + $ torqueBefore 0.05 + $ withAccVelWthHiteff' (autogunSpread/2) (50,0) 3 + $ threeEff' bulHitCr' bulHitWall' bulHitFF' +singleFireMode = shootWithSound (fromIntegral autoGunSound) + $ withRecoil 40 + $ torqueAfter 0.03 + $ withAccVelWthHiteff' (autogunSpread/2) (50,0) 3 + $ threeEff' bulHitCr' bulHitWall' bulHitFF' + +incMode :: Int -> World -> World +incMode _ w + = case newMode of + 0 -> w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode .~ 0 + & creatures . ix 0 . crInv . ix itRef . itName .~ "autoGun .........." + & creatures . ix 0 . crInv . ix itRef . itHammer .~ NoHammer + & creatures . ix 0 . crInv . ix itRef . itEffect .~ NoItEffect + & creatures . ix 0 . crInv . ix itRef . wpFire .~ autoFireMode + 1 -> w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode .~ 1 + & creatures . ix 0 . crInv . ix itRef . itName .~ "autoGun ." + & creatures . ix 0 . crInv . ix itRef . itHammer .~ HammerUp + & creatures . ix 0 . crInv . ix itRef . itEffect .~ wpRecock + & creatures . ix 0 . crInv . ix itRef . wpFire .~ singleFireMode + where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel + oldMode = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode + newMode = fromMaybe 1 $ fmap f oldMode + f x = mod (x+1) 2 +decMode :: Int -> World -> World +decMode _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode %~ f + & creatures . ix 0 . crInv . ix itRef . itName .~ "autoGun" ++ g newMode + where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel + oldMode = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode + newMode = fromMaybe 1 $ fmap f oldMode + f x = mod (x-1) 2 + g 1 = " ." + g 2 = " ..." + g 0 = " .........." + +rezGun = defaultGun + { _itName = "reanimator" + , _wpMaxAmmo = 50 + , _wpLoadedAmmo = 50 + , _wpAmmoType = Battery + , _wpReloadTime = 80 + , _wpReloadState = 0 + , _wpFireRate = 0 + , _wpFireState = 0 + , _wpFire = shoot aTeslaArc + , _wpSpread = 0.001 + , _wpRange = 20 + , _itFloorPict = onLayer FlItLayer $ color chartreuse $ pictures [polygon $ rectNESW 7 3 1 (-3) + ,polygon $ rectNESW (-1) 3 (-7) (-3) + ] + + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.4 + , _itAimingRange = 0 + , _itEquipPict = drawWeapon $ color chartreuse $ pictures [polygon $ rectNESW 7 3 1 (-3) + ,polygon $ rectNESW (-1) 3 (-7) (-3) + ] + } +teslaGun = autoGun + { _itName = "teslaGun" + , _itIdentity = TeslaGun + , _wpMaxAmmo = 200 + , _wpLoadedAmmo = 200 + , _wpAmmoType = Battery + , _wpReloadTime = 80 + , _wpReloadState = 0 + , _wpFireRate = 0 + , _wpFireState = 0 + , _wpFire = shoot aTeslaArc + , _wpSpread = 0.001 + , _wpRange = 20 + , _itFloorPict = onLayer FlItLayer $ color blue $ pictures [polygon $ rectNESW 7 3 1 (-3) + ,polygon $ rectNESW (-1) 3 (-7) (-3) + ] + + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.4 + , _itZoom = basicItZoom + , _itAimingRange = 0 + , _itEquipPict = drawWeapon $ color blue $ pictures [polygon $ rectNESW 7 3 1 (-3) + ,polygon $ rectNESW (-1) 3 (-7) (-3) + ] + } +lasGun = autoGun + { _itName = "lasGun ////" + , _itIdentity = LasGun + , _wpMaxAmmo = 200 + , _wpLoadedAmmo = 200 + , _wpAmmoType = Battery + , _wpReloadTime = 80 + , _wpReloadState = 0 + , _wpFireRate = 0 + , _wpFireState = 0 + , _wpFire = shoot aLaser + , _wpSpread = 0.001 + , _wpRange = 20 + , _itFloorPict = onLayer FlItLayer $ color blue $ polygon $ rectNESW 3 3 (-3) (-3) + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.4 + , _itAimingRange = 1 + , _itEquipPict = drawWeapon $ color blue $ polygon $ rectNESW 3 3 (-3) (-3) + , _itAttachment = Just $ ItPhaseV 1 + , _itScrollUp = incPhaseV + , _itScrollDown = decPhaseV + } +incPhaseV :: Int -> World -> World +incPhaseV _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV %~ f + & creatures . ix 0 . crInv . ix itRef . itName .~ "lasGun" ++ g newPhaseV + where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel + oldPhaseV = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV + newPhaseV = fromMaybe 1 $ fmap f oldPhaseV + f 0.2 = 0.5 + f 0.5 = 1 + f 1 = 2 + f 2 = 5 + f 5 = 5 + g 0.2 = " //\\\\" + g 0.5 = " ///\\" + g 1 = " ////" + g 2 = " \\///" + g 5 = " \\\\//" +decPhaseV :: Int -> World -> World +decPhaseV _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV %~ f + & creatures . ix 0 . crInv . ix itRef . itName .~ "lasGun" ++ g newPhaseV + where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel + oldPhaseV = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV + newPhaseV = fromMaybe 1 $ fmap f oldPhaseV + f 0.2 = 0.2 + f 0.5 = 0.2 + f 1 = 0.5 + f 2 = 1 + f 5 = 2 + g 0.2 = " //\\\\" + g 0.5 = " ///\\" + g 1 = " ////" + g 2 = " \\///" + g 5 = " \\\\//" +forceFieldGun = defaultGun + { _itName = "forceField" + , _itIdentity = ForceFieldGun + , _wpMaxAmmo = 100 + , _wpLoadedAmmo = 100 + , _wpAmmoType = Battery + , _wpReloadTime = 40 + , _wpReloadState = 0 + , _wpFireRate = 10 + , _wpFireState = 0 + , _wpFire = forceFieldFire + , _wpSpread = 0.02 + , _wpRange = 20 + , _itFloorPict = onLayer FlItLayer $ polygon [(-4,-4),(-4,4),(4,4),(4,0),(0,0),(0,-4)] + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.4 + , _itAimingRange = 0.5 + } +-- grapGun = defaultGun +-- { _itName = "grapGun" +-- , _itIdentity = GrapGun +-- , _wpMaxAmmo = 1 +-- , _wpLoadedAmmo = 1 +-- , _wpAmmoType = Battery +-- , _wpReloadTime = 40 +-- , _wpReloadState = 0 +-- , _wpFireRate = 10 +-- , _wpFireState = 0 +-- , _wpFire = grapFire +-- , _wpSpread = 0.002 +-- , _wpRange = 20 +-- , _wpIsAuto = False +-- , _itFloorPict = onLayer FlItLayer $ polygon [(-4,-4),(-4,4),(4,4),(4,0),(0,0),(0,-4)] +-- , _itAmount = 1 +-- , _itMaxStack = 1 +-- , _itAimingSpeed = 1 +-- , _itAimingRange = 0.5 +-- } +tractorGun = autoGun + { _itName = "tractorGun" + , _itIdentity = TractorGun + , _wpMaxAmmo = 10000 + , _wpLoadedAmmo = 10000 + , _wpAmmoType = Battery + , _wpReloadTime = 40 + , _wpReloadState = 0 + , _wpFireRate = 0 + , _wpFireState = 0 + , _wpFire = shoot $ aTractorBeam 0 + , _wpSpread = 0.00001 + , _wpRange = 20 + , _itFloorPict = onLayer FlItLayer $ color blue $ pictures [polygon $ rectNESW 1.5 6 (-1.5) 0 ] + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.4 + , _itAimingRange = 0.5 + , _itEquipPict = drawWeapon $ color blue $ pictures [polygon $ rectNESW 1.5 6 (-1.5) 0 ] + } +launcher = defaultGun + { _itName = "launcher" + , _itIdentity = Launcher + , _wpMaxAmmo = 30 + , _wpLoadedAmmo = 30 + , _wpAmmoType = Shell + , _wpReloadTime = 80 + , _wpReloadState = 0 + , _wpFireRate = 20 + , _wpFireState = 0 + , _wpFire = shoot $ aRocket + , _wpSpread = 0.02 + , _wpRange = 20 + , _itFloorPict = onLayer FlItLayer $ color cyan $ polygon $ rectNESW 5 5 (-5) (-5) + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.2 + , _itAimingRange = 0.5 + , _itEquipPict = drawWeapon $ color cyan $ polygon $ rectNESW 5 5 (-5) (-5) + , _itHammer = NoHammer + , _itEffect = NoItEffect + } +remoteLauncher = defaultGun + { _itName = "remoteLauncher" + , _itIdentity = RemoteLauncher + , _wpMaxAmmo = 1 + , _wpLoadedAmmo = 1 + , _wpAmmoType = Shell + , _wpReloadTime = 80 + , _wpReloadState = 0 + , _wpFireRate = 10 + , _wpFireState = 0 + , _wpFire = fireRemoteLauncher + , _wpSpread = 0.02 + , _wpRange = 20 + , _itFloorPict = onLayer FlItLayer $ color cyan $ polygon $ rectNESW 5 5 (-5) (-5) + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.2 + , _itAimingRange = 0.5 + , _itEquipPict = drawWeapon $ color cyan $ polygon $ rectNESW 5 5 (-5) (-5) + , _itAttachment = Just $ ItScope (0,0) 0 1 True + } +hvAutoGun = autoGun + { _itName = "hvMachineGun" + , _itIdentity = HvAutoGun + , _wpMaxAmmo = 100 + , _wpLoadedAmmo = 100 + , _wpAmmoType = PistolBullet + , _wpReloadTime = 200 + , _wpReloadState = 0 + , _wpFireRate = 25 + , _wpFireState = 0 + , _wpFire = rateIncAB 24 12 (torqueBeforeForced 0.1 mkHvBul) + $torqueAfter 0.2 mkHvBul + , _wpSpread = autogunSpread + , _wpRange = 20 + , _itFloorPict = onLayer FlItLayer $ color orange $ polygon $ rectNESW 5 5 (-5) (-5) + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.2 + , _itAimingRange = 1 + , _itEquipPict = drawWeapon $ color orange $ polygon $ rectNESW 5 5 (-5) (-5) + } + where mkHvBul = withSound (fromIntegral longGunSound) + $ withThinSmoke + $ withAccVelWthHiteff' 0 (80,0) 6 + $ threeEff' + hvBulHitCr' hvBulHitWall' bulHitFF' + +ltAutoGun = autoGun + { _itName = "autoPistol" + , _itIdentity = LtAutoGun + , _wpMaxAmmo = 25 + , _wpLoadedAmmo = 25 + , _wpAmmoType = PistolBullet + , _wpReloadTime = 80 + , _wpReloadState = 0 + , _wpFireRate = 4 + , _wpFireState = 0 + , _wpFire = shootWithSound 0 $ withAccVelWthHiteff' 0.3 (30,0) 2 bulletEffect' + , _wpSpread = 0.5 + , _wpRange = 20 + , _itFloorPict = onLayer FlItLayer $ color green $ pictures [polygon $ rectNSWE 4 (-4) (-4) 0 + ,circleSolid 4 + ] + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 1 + , _itAimingRange = 0 + , _itZoom = basicItZoom + , _itEquipPict = drawWeapon $ color green $ pictures [polygon $ rectNSWE 4 (-4) (-4) 0 + ,circleSolid 4 + ] + } +miniGun = autoGun + { _itName = "miniGun" + , _itIdentity = MiniGun + , _wpMaxAmmo = 150 + , _wpLoadedAmmo = 150 + , _wpAmmoType = PistolBullet + , _wpReloadTime = 200 + , _wpReloadState = 0 + , _wpFireRate = 2 + , _wpFireState = 0 + , _wpFire = withWarmUp 50 $ torqueBefore 0.03 $ withSidePush 50 $ withRecoil 15 + $ withOffsetAccVelWthHiteff' 9 0.1 (30,0) 2 bulletEffect' + , _wpSpread = autogunSpread + , _wpRange = 20 + , _itFloorPict = onLayer FlItLayer $ color red $ polygon $ rectNESW 9 5 (-9) (-5) + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.4 + , _itAimingRange = 1 + , _itEquipPict = drawWeapon $ color red $ polygon $ rectNESW 9 5 (-9) (-5) + } +spreadGun = defaultGun + { _itName = "spreadgun" + , _itIdentity = SpreadGun + , _wpMaxAmmo = 5 + , _wpLoadedAmmo = 5 + , _wpAmmoType = PistolBullet + , _wpReloadTime = 80 + , _wpReloadState = 0 + , _wpFireRate = 20 + , _wpFireState = 0 + , _wpFire = shootWithSound (fromIntegral shotgunSound) + $ withRecoil 100 + $ spreadNumVelWthHiteff' spreadGunSpread 9 (30,0) 2 bulletEffect' + , _wpSpread = spreadGunSpread + , _wpRange = 20 + , _itFloorPict = onLayer FlItLayer $ color green $ pictures [ polygon [(-3,0),(3,6),(3,-6)] + ] + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 1 + , _itAimingRange = 0 + , _itEquipPict = drawWeapon $ color green $ pictures [ polygon [(-3,0),(3,6),(3,-6)] + ] + } +-- shatterGun = defaultGun +-- { _itName = "shatterGun" +-- , _itIdentity = ShatterGun +-- , _wpMaxAmmo = 50 +-- , _wpLoadedAmmo = 50 +-- , _wpAmmoType = PistolBullet +-- , _wpReloadTime = 80 +-- , _wpReloadState = 0 +-- , _wpFireRate = 40 +-- , _wpFireState = 0 +-- , _wpFire = shatterGunFire +-- , _wpSpread = 3.14 +-- , _wpRange = 20 +-- , _wpIsAuto = False +-- , _itFloorPict = polygon [(-4,-4),(-4,4),(4,4),(4,0),(0,0),(0,-4)] +-- , _itAmount = 1 +-- , _itMaxStack = 1 +-- , _itAimingSpeed = 1 +-- , _itAimingRange = 0.5 +-- } +multGun = defaultGun + { _itName = "multGun" + , _itIdentity = MultGun + , _wpMaxAmmo = 2 + , _wpLoadedAmmo = 2 + , _wpAmmoType = PistolBullet + , _wpReloadTime = 40 + , _wpReloadState = 0 + , _wpFireRate = 20 + , _wpFireState = 0 + , _wpFire = shootWithSound (fromIntegral shotgunSound) + $ withRecoil 200 + $ numVelWthHitEff' 5 (50,0) 4 bulletEffect' + , _wpSpread = spreadGunSpread + , _wpRange = 20 + , _itFloorPict = onLayer FlItLayer $ multGunPic + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.4 + , _itAimingRange = 1 + , _itZoom = basicItZoom {_itAimZoomFac = 1.5} + , _itEquipPict = drawWeapon $ multGunPic + } + where multGunPic = color red $ pictures + [ polygon $ rectNSEW 12 8 2 (-2) + , polygon $ rectNSEW 7 3 2 (-2) + , polygon $ rectNSEW 2 (-2) 2 (-2) + , polygon $ rectNSEW (-3) (-7) 2 (-2) + , polygon $ rectNSEW (-8) (-12) 2 (-2) + , polygon [(-1.5,12),(-2,12),(-2,-12),(-1.5,-12)] + ] +longGun = defaultGun + { _itName = "elephantGun" + , _itIdentity = LongGun + , _wpMaxAmmo = 1 + , _wpLoadedAmmo = 1 + , _wpAmmoType = PistolBullet + , _wpReloadTime = 80 + , _wpReloadState = 0 + , _wpFireRate = 100 + , _wpFireState = 0 + , _wpFire = shootWithSound (fromIntegral longGunSound) + $ withThickSmoke + $ torqueAfter 0.05 + $ withAccVelWthHiteff' 0 (60,0) 6 + $ threeEff' + hvBulHitCr' hvBulHitWall' bulHitFF' + + , _wpSpread = 0.0 + , _wpRange = 200 + , _itFloorPict = onLayer FlItLayer $ pictures [color orange $ polygon $ rectNESW 3 6 (-3) (-6) ] + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.2 + , _itAimingRange = 1 + , _itZoom = basicItZoom {_itAimZoomMax = 0.5, _itAimZoomMin = 0.5} + , _itEquipPict = drawWeapon $ pictures [color orange $ polygon $ rectNESW 3 6 (-3) (-6) ] + , _itScrollUp = startZoomInLongGun + , _itScrollDown = startZoomOutLongGun + , _itAttachment = Just $ ItScope (0,0) 0 1 False + , _itEffect = itemLaserScopeEffect + } + +startZoomInLongGun :: Int -> World -> World +startZoomInLongGun _ w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment . _Just . scopeZoomChange %~ \x -> max 5 (x + 5) +startZoomOutLongGun :: Int -> World -> World +startZoomOutLongGun _ w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment . _Just . scopeZoomChange %~ \x -> min (-5) (x-5) +-- (\x -> - 10) + + +poisonSprayer = autoGun + { _itName = "poisonSprayer" + , _itIdentity = PoisonSprayer + , _wpMaxAmmo = 500 + , _wpLoadedAmmo = 500 + , _wpAmmoType = LiquidFuel + , _wpReloadTime = 100 + , _wpReloadState = 0 + , _wpFireRate = 0 + , _wpFireState = 0 + , _wpFire = shoot $ aGasCloud + , _wpSpread = flamerAngle + , _wpRange = 8 + , _itFloorPict = onLayer FlItLayer $ color yellow $ polygon $ rectNESW 4 4 (-4) (-4) + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.2 + , _itAimingRange = 0 + , _itZoom = basicItZoom + , _itEquipPict = drawWeapon $ color yellow $ polygon $ rectNESW 4 4 (-4) (-4) + } + +flamer = autoGun + { _itName = "flamethrower" + , _itIdentity = Flamethrower + , _wpMaxAmmo = 250 + , _wpLoadedAmmo = 250 + , _wpAmmoType = LiquidFuel + , _wpReloadTime = 100 + , _wpReloadState = 0 + , _wpFireRate = 0 + , _wpFireState = 0 + , _wpFire = shoot $ aFlame 0 + , _wpSpread = flamerAngle + , _wpRange = 8 + , _itFloorPict = onLayer FlItLayer $ color yellow $ polygon $ rectNESW 4 4 (-4) (-4) + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 0.5 +-- , _itAimingSpeed = 1 +-- , _itAimingSpeed = 0.2 + , _itAimingRange = 0 + , _itZoom = basicItZoom {_itAimZoomMax = 5, _itAimZoomMin = 1.5} + , _itEquipPict = drawWeapon $ color yellow $ polygon $ rectNESW 4 4 (-4) (-4) + , _itAttachment = Nothing + } +blinkGun = defaultGun + { _itName = "blinker" + , _itIdentity = Blinker + , _wpMaxAmmo = 100 + , _wpLoadedAmmo = 100 + , _wpAmmoType = Battery + , _wpReloadTime = 20 + , _wpReloadState = 0 + , _wpFireRate = 0 + , _wpFireState = 0 + , _wpFire = shoot aSelf + , _wpSpread = 0.05 + , _wpRange = 20 + , _itFloorPict = onLayer FlItLayer $ polygon [(-2,-2),(-2,2),(2,2),(2,0),(0,0),(0,-2)] + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingSpeed = 1 + , _itAimingRange = 0 + } + +withWarmUp :: Int -> (Int -> World -> World) -> Int -> World -> World +withWarmUp t f cid w + | reloadCondition = fromMaybe w $ reloadWeapon cid w + | _wpReloadState item /= 0 = w + | fState == 0 = set (pointerToItem . wpFire) (withWarmUp 100 f) + $ set (pointerToItem . wpFireState) 2 + w + | t > 1 = set (pointerToItem . wpFire) (withWarmUp (t-1) f) + $ set (pointerToItem . wpFireState) 2 + $ soundFrom (CrWeaponSound cid) 26 1 0 + w + | t > 0 = set (pointerToItem . wpFire) (withWarmUp (t-1) f) + $ set (pointerToItem . wpFireState) 2 + w + -- | otherwise = set (pointerToItem . wpFire) (withWarmUp 0 f) + | otherwise = set (pointerToItem . wpFire) (withWarmUp 1 f) + $ over (pointerToItem . wpLoadedAmmo) (\ammo -> ammo-1) + $ set (pointerToItem . wpFireState) 2 + $ f cid + $ continueSoundFrom (CrWeaponSound cid) 28 2 0 + w + where cr = _creatures w IM.! cid + itRef = _crInvSel cr + item = _crInv cr IM.! itRef + pointerToItem = creatures . ix cid . crInv . ix itRef + fState = _wpFireState item + fRate = _wpFireRate item + reloadCondition = _wpLoadedAmmo item == 0 +-- rotC = case cid of 0 -> fst $ randomR (-0.03,0.03) (_randGen w) +-- _ -> 0 + +withSound :: Int -> (Int -> World -> World) -> Int -> World -> World +withSound soundid f cid = soundOnce soundid . f cid + +withRecoil :: Float -> (Int -> World -> World) -> Int -> World -> World +withRecoil recoilAmount eff cid w = eff cid . over (creatures . ix cid) pushback $ w + where pushback cr = over crPos +-- where pushback cr = colCrWall w $ over crPos + (+.+ rotateV (_crDir cr) ((-recoilAmount) / _crMass cr ,0)) + cr +withSidePush :: Float -> (Int -> World -> World) -> Int -> World -> World +withSidePush maxSide eff cid w = eff cid . over (creatures . ix cid) push $ w + where push cr = over crPos + (+.+ rotateV (_crDir cr) (0,(pushAmount) / _crMass cr)) + cr + (pushAmount, _) = randomR (-maxSide,maxSide) $ _randGen w + + + +shootWithSound :: Int -> (Int -> World -> World) -> Int -> World -> World +shootWithSound soundid f cid w + | fireCondition = over (pointerToItem . wpLoadedAmmo) (\ammo -> ammo-1) + $ soundOnce soundid + $ set (pointerToItem . wpFireState) (_wpFireRate item) + $ f cid w + | reloadCondition = fromMaybe w $ reloadWeapon cid w + | otherwise = w + where cr = (_creatures w IM.! cid) + itRef = _crInvSel cr + item = _crInv cr IM.! itRef + pointerToItem = creatures . ix cid . crInv . ix itRef + fireCondition = _wpReloadState item == 0 + && _wpFireState item == 0 + && _wpLoadedAmmo item > 0 + reloadCondition = _wpLoadedAmmo item == 0 + +shoot :: (Int -> World -> World) -> Int -> World -> World +shoot f cid w | fireCondition = over (pointerToItem . wpLoadedAmmo) (\ammo -> ammo-1) + $ set (pointerToItem . wpFireState) (_wpFireRate item) + $ f cid w + | reloadCondition = fromMaybe w $ reloadWeapon cid w + | otherwise = w + where cr = (_creatures w IM.! cid) + itRef = _crInvSel cr + item = _crInv cr IM.! itRef + pointerToItem = creatures . ix cid . crInv . ix itRef + fireCondition = _wpReloadState item == 0 + && _wpFireState item == 0 + && _wpLoadedAmmo item > 0 + reloadCondition = _wpLoadedAmmo item == 0 + +aTeslaArc :: Int -> World -> World +aTeslaArc cid w = aTeslaArc' cid + $ soundFrom (CrWeaponSound cid) 25 1 0 w + +aTeslaArc' :: Int -> World -> World +aTeslaArc' cid w = over particles (IM.insert i (makeTeslaArcAt i pos dir)) + $ flareAt' cyan 0.03 0.1 (pos +.+ 5 *.* unitVectorAtAngle dir) + $ set randGen g w + where cr = (_creatures w IM.! cid) + i = newParticleKey w + pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir) + +.+ sideOffset *.* vNormal (unitVectorAtAngle dir) + (sideOffset,g) = randomR (-5,5) $ _randGen w + dir = _crDir cr + +aLaser :: Int -> World -> World +aLaser cid w = over particles' ( (:) (makeLaserAt phaseV pos dir (Just cid))) + $ soundFrom LasSound 24 1 0 + $ flareAt' yellow 0.02 0.05 (pos +.+ 5 *.* unitVectorAtAngle dir) + w + where cr = (_creatures w IM.! cid) + i = newParticleKey w + pos = _crPos cr +.+ ((_crRad cr +3) *.* unitVectorAtAngle dir) + dir = _crDir cr + phaseV = fromMaybe 1 $ cr ^? crInv . ix j . itAttachment . _Just . itPhaseV + j = _crInvSel cr + + +aTractorBeam :: Int -> Int -> World -> World +aTractorBeam col cid w + = set (creatures . ix cid . crInv . ix itRef . wpFire) + (shoot $ aTractorBeam ((col + 1) `mod` 10)) + $ over particles (IM.insert i (tractorBeamAt col i pos dir)) w + where i = newParticleKey w + cr = (_creatures w IM.! cid) + pos = _crPos cr +.+ ((_crRad cr +10) *.* unitVectorAtAngle dir) + dir = _crDir cr + itRef = _crInvSel cr + +aRocket :: Int -> World -> World +aRocket cid w + = soundOnce (fromIntegral launcherSound) + $ over particles (IM.insert i (makeShellAt i cid pos dir)) w + where i = newParticleKey w + cr = (_creatures w IM.! cid) + pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir) + dir = _crDir cr + +makeShellAt :: Int -> Int -> Point2 -> Float -> Particle +makeShellAt i cid pos dir = Particle + { _ptPos = pos + , _ptStartPos = pos + , _ptVel = rotateV dir (1,0) + , _ptPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic + , _ptID = i + , _ptUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) + } + +moveShell :: Int -> Int -> Int -> Float -> Point2 -> World -> World +moveShell time i cid rot accel w + | time > 40 = if circOnSomeWall oldPos 4 w + then shellExplosionAt oldPos $ over particles (IM.delete i) w + else over (particles . ix i . ptPos) (+.+ vel) + $ set (particles . ix i . ptPict) piclow + $ set (particles . ix i . ptUpdate) + (moveShell (time-1) i cid rot (rotateV rot accel)) + w + | time == 35 = case thingHit of + Just p -> shellExplosionAt oldPos + $ over particles (IM.delete i) w + Nothing -> over (particles . ix i . ptPos) (+.+ vel) + $ set (particles . ix i . ptPict) pic + $ set (particles . ix i . ptUpdate) + (moveShell (time-1) i cid spin accel) + w + | time >= 20 = case thingHit of + Just p -> shellExplosionAt oldPos + $ over particles (IM.delete i) w + Nothing -> over (particles . ix i . ptPos) (+.+ vel) + $ set (particles . ix i . ptPict) pic + $ set (particles . ix i . ptUpdate) + (moveShell (time-1) i cid rot (rotateV rot accel)) + w + | time > -99 + = case thingHit of + Just p -> shellExplosionAt oldPos + $ stopSoundFrom (ShellSound i) + $ over particles (IM.delete i) w + Nothing -> over (particles . ix i . ptPos) (+.+ vel) + $ set randGen g + $ set (particles . ix i . ptPict) pic + $ set (particles . ix i . ptUpdate) + (moveShell (time-1) i cid rot (rotateV rot accel)) + $ over (particles . ix i . ptVel) (\v -> accel +.+ frict *.* v) + $ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250 + $ smokeGen + $ makeFlameletTimed oldPos + (0.5 *.* rotateV (pi+sparkD) accel) (levLayer UPtLayer) Nothing 3 20 + $ makeFlameletTimed (0.5 *.* (newPos +.+ oldPos)) + (0.5 *.* rotateV (pi+sparkD) accel) (levLayer UPtLayer) Nothing 3 20 + w + | time > -200 = case thingHit of + Just p -> shellExplosionAt oldPos + $ stopSoundFrom (ShellSound i) + $ over particles (IM.delete i) w + Nothing -> over (particles . ix i . ptPos) (+.+ vel) + $ set (particles . ix i . ptPict) pic + $ set (particles . ix i . ptUpdate) + (moveShell (time-1) i cid rot (rotateV rot accel)) + w + | otherwise = shellExplosionAt oldPos + $ stopSoundFrom (ShellSound i) + $ over particles (IM.delete i) w + where pt = _particles w IM.! i + oldPos = _ptPos pt + vel = _ptVel pt + newPos = oldPos +.+ vel + (frict,g) = randomR (0.6,0.9) $ _randGen w + (sparkD,_) = randomR (-0.5,0.5) $ _randGen w + dir = argV $ vel + pic = onLayer PtLayer $ uncurry translate newPos $ rotate (-radToDeg (argV accel)) shellPic + piclow = onLayerL [levLayer CrLayer - 2] + $ uncurry translate newPos $ rotate (-radToDeg (argV accel)) shellPic + hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w + hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w + thingHit = hitCr <|> hitWl + spin = case w ^? creatures . ix cid of + Just cr -> min 0.1 $ max (-0.1) + $ (normalizeAnglePi (dir - _crDir cr)) / 20 + _ -> 0 + (v1:v2:v3:_) = fst $ runState ((sequence . repeat . randInCirc) 0.1) $ _randGen w + (r1:r2:r3:_) = map ((*.*) 100) (v2:v3:v1:[]) + (t1:t2:t3:_) = randomRs ( 15,20) $ _randGen w + (s1:s2:s3:_) = map (\s -> fromIntegral s * 0.1 - 1) (t3:t2:t1:[]) + -- ((r1:r2:r3:_),_) = runState ((sequence . repeat . randInCirc) 10) $ _randGen w + -- v1 = fst $ runState (randInCirc 0.5) $ _randGen w + smokeGen = makeSmokeAt'' v1 s1 t1 (newPos +.+ r1) + . makeSmokeAt'' v2 s2 t2 (newPos +.+ r2) + -- . makeSmokeAt'' v3 s3 t3 (newPos +.+ r3) + + +normalizeAnglePi angle | normalizeAngle angle > pi = normalizeAngle angle - 2*pi + | otherwise = normalizeAngle angle + +shellPic = color black $ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)] +remoteShellPic :: Int -> Picture +remoteShellPic i | rem (i+200) 20 < 9 = polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)] + | otherwise = pictures [ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)] + , color col $ circleSolid 3 + ] + where col | i > (-99) = green + | otherwise = red + +shellExplosionAt = makeExplosionAt + +tractorBeamAt :: Int -> Int -> Point2 -> Float -> Particle +tractorBeamAt colID i pos dir = Particle + { _ptPos = pos + , _ptStartPos = p' + , _ptVel = d + , _ptPict = blank + , _ptID = i + , _ptUpdate = updateTractor colID 10 i + } + where d = unitVectorAtAngle dir + p' = pos +.+ 400 *.* d + +spreadNumVelWthHiteff' :: Float -> Int -> Point2 -> Float -> HitEffect' -> Int -> World -> World +spreadNumVelWthHiteff' spread num vel wth eff cid w + = over particles' (newbuls ++) + $ flip (foldr muzFlareAt) poss + w + where cr = _creatures w IM.! cid + newbuls = zipWith3 (\pos d colid -> aGenBulAt' (Just cid) (numColor colid) + pos (rotateV d vel) eff wth + ) poss dirs colids + pos' = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr) + poss = map ((+.+) $ _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)) + $ evalState ((sequence . take num . repeat . randInCirc) 5) $ _randGen w + dirs = map ((+) (_crDir cr)) + $ zipWith (+) [-spread,-spread+(2*spread/(fromIntegral num))..] + $ randomRs (0,spreadGunSpread/5) (_randGen w) + colids = take num $ randomRs (0,11) (_randGen w) + +numVelWthHitEff' :: Int -> Point2 -> Float -> HitEffect' -> Int -> World -> World +numVelWthHitEff' num vel wth eff cid w + = over particles' (newbuls ++) + $ flip (foldr muzFlareAt) (take num poss) + w + where cr = _creatures w IM.! cid + newbuls = zipWith (\pos colid -> aGenBulAt' (Just cid) (numColor colid) + pos (rotateV d vel) eff wth) + poss colids + d = _crDir cr + poss = map (\o -> o +.+ pos) offsets + maxOffset = fromIntegral num * 2.5 - 2.5 + offsets = map (\y -> rotateV d (0,y)) [-maxOffset,5-maxOffset..] + colids = take num $ randomRs (0,11) (_randGen w) + pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle d + pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr) + +aGasCloud :: Int -> World -> World +aGasCloud cid w + = -- soundFrom Flame fireSound 2 500 + insertCloud $ set randGen g $ + w + where + (a,g) = randomR (-0.1,0.1) (_randGen w) + cr = (_creatures w IM.! cid) + dir = _crDir cr + a + pos = _crPos cr +.+ ((_crRad cr + 2.9) *.* unitVectorAtAngle (_crDir cr)) + pos2 = (0.5 *.* vel) +.+ + _crPos cr +.+ ((_crRad cr + 2.9) *.* unitVectorAtAngle (_crDir cr)) + vel = (_crPos cr -.- _crOldPos cr) +.+ 4 *.* unitVectorAtAngle dir + insertCloud = makeGasCloud pos vel -- . makeFlame pos2 vel (Just cid) + +makeGasCloud :: Point2 -> Point2 -> World -> World +makeGasCloud pos vel w = over clouds (IM.insert i theCloud) + $ set randGen g w + where i = newKey $ _clouds w + theCloud = Cloud { _clID = i + , _clPos = pos + , _clVel = vel + , _clPict = \_ -> onLayer CrLayer $ color (withAlpha 0.1 col) + $ circleSolid 20 + , _clRad = 20 + , _clTimer = 200 + , _clEffect = cloudPoisonDamage + } + (col, g) = runState (takeOne [green,yellow]) $ _randGen w + +cloudPoisonDamage :: Cloud -> World -> World +cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedCrs + where damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint (_clPos c) w + f cr = dist (_crPos cr) (_clPos c) < _crRad cr + _clRad c + doDam cr = cr & crState . crDamage %~ (:) (PoisonDam 1) + +aFlame :: Float -> Int -> World -> World +aFlame a cid w + = shakeCr cid 2 + $ soundFrom Flame fireSound 2 500 + $ insertFlame $ resetAngle $ set randGen g $ + w + where + (a2,g) = randomR (-0.1,0.1) (_randGen w) + angle = min flamerAngle $ max (-flamerAngle) (a + a2) + cr = (_creatures w IM.! cid) + dir = _crDir cr + angle + pos = _crPos cr +.+ ((_crRad cr + 2.9) *.* unitVectorAtAngle (_crDir cr)) + pos2 = (0.5 *.* vel) +.+ + _crPos cr +.+ ((_crRad cr + 2.9) *.* unitVectorAtAngle (_crDir cr)) + w1 = set randGen g w + i = newParticleKey w1 + -- vel = (_crPos cr -.- _crOldPos cr) +.+ 4 *.* unitVectorAtAngle dir + vel = (_crPos cr -.- _crOldPos cr) +.+ 4 *.* unitVectorAtAngle dir + insertFlame = makeFlame pos vel (Just cid) -- . makeFlame pos2 vel (Just cid) + resetAngle = set (creatures . ix cid . crInv . ix (_crInvSel cr) . wpFire) + (shoot $ aFlame angle) + +makeFlame :: Point2 -> Point2 -> Maybe Int -> World -> World +makeFlame pos vel maycid = over particles' ((:) theFlame) + where theFlame = + Pt' { _ptPict' = blank + , _ptUpdate' = moveFlame vel + , _btVel' = vel + , _btColor' = red + , _btPos' = pos + , _btPassThrough' = maycid + , _btWidth' = 4 + , _btTimer' = 100 + , _btHitEffect' = threeEff' (doFlameDam 1) noEff noEff + } + +moveFlame :: Point2 -> World -> Particle' -> (World, Maybe Particle') +moveFlame rotd w pt = + case _btTimer' pt of + time | time <= 0 -> (smokeGen w, Nothing) + | otherwise -> + case thingsHitExceptCr (_btPassThrough' pt) sp ep w of + -- ((p,(E3x1 cr)):_) -> (damcr cr p $ smokeGen damcrs, Nothing) + ((p,(E3x1 cr)):_) + -> (soundFrom Flame fireSound 2 500 + $ over worldEvents ((.) $ lowLightRadAt orange 0.05 8 50 ep) + damcrs + , mvPt') + (thing@(p,(E3x2 wl)):_) -> (hiteff thing damcrs, rfl wl p) + _ -> (soundFrom Flame fireSound 2 500 +-- adding reflective glare is too intensive for this laptop + $ over worldEvents ((.) $ lowLightRadAt orange 0.05 8 50 ep) + damcrs + , mvPt) + where sp = _btPos' pt + vel = _btVel' pt + ep = sp +.+ vel + mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep, _ptPict' = thepic ep + , _btPassThrough' = Nothing + ,_btVel' = 0.98 *.* vel} + mvPt' = Just $ pt {_btTimer' = time - 1, _btPos' = ep, _ptPict' = thepic ep + , _btPassThrough' = Nothing + ,_btVel' = 0.7 *.* vel} + damcrs = foldr ($) w $ map (\cr -> hiteff (ep,E3x1 cr)) $ filter closeCrs + $ IM.elems $ _creatures w + closeCrs cr = dist ep (_crPos cr) + < _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80)) + + 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd) + angleCoeff x = abs $ 1 - (abs $ (x * 2 - pi) / (pi)) + damcr cr p = over (creatures . ix (_crID cr) . crState . crDamage) + ((:) $ Flaming (div time 10) sp p ep) + hiteff = _btHitEffect' pt pt + thepic p' = pic p' <> piu p' <> pi2 p' <> glow p' + pic p' = onLayerL [levLayer UPtLayer,6] $ uncurry translate (prot3 p') + $ rotate (90 + (negate $ radToDeg $ argV rotd)) + $ scale scaleChange 1 + -- $ color white + -- $ circleSolid 5 + $ pictures [color white $ circleSolid 4 + ,color (withAlpha 0.5 white) $ circleSolid 5 + ] + -- $ rotate (radToDeg (fromIntegral time * 10)) + -- $ polygon [(-5,-2),(5,-2),(5,2),(-5,2)] + pi2 p' = onLayerL [levLayer UPtLayer,4] $ uncurry translate (prot p') + -- $ rotate ( (fromIntegral time * 5)) + $ rotate (90 + (negate $ radToDeg $ argV rotd)) + -- $ color (mixColors 0.5 0.5 orange white) + -- $ polygon [(-6,-6),(6,-6),(6,6),(-6,6)] + $ scale (scaleChange + 0.5) 1.5 + $ pictures [color orange $ circleSolid 4.5 + ,color (withAlpha 0.5 orange) $ circleSolid 5 + ] + -- $ color orange + -- $ circleSolid 5 + prot p' = p' +.+ rotateV (fromIntegral time * 1) (0,1) + prot2 p' = p' +.+ rotateV (negate $ fromIntegral time * 1) (0,1) + prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (0,2) + piu p' = onLayerL [levLayer UPtLayer,2] $ uncurry translate (prot2 p') + $ rotate (90 + (negate $ radToDeg $ argV rotd)) + -- $ rotate ((fromIntegral time * (-10))) + $ scale (scaleChange + 1) 2 + $ pictures [color red $ circleSolid 4.5 + ,color (withAlpha 0.5 red) $ circleSolid 5 + ] + -- $ color (dark red) + -- $ circleSolid 5 + -- $ polygon [(-8,-8),(8,-8),(8,8),(-8,8) ] + rfl wl p = Just $ pt {_btTimer' = time -1, _btPos' = pOut p + , _btVel' = reflV wl, _ptPict' = thepic $ pOut p + } + glow p' = onLayerL [levLayer UPtLayer,0] $ uncurry translate p' + $ color (withAlpha 0.02 orange) + $ circleSolid 50 + pOut p = p +.+ safeNormalizeV (sp -.- p) + --reflV wall = (0.6 *.* reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0) + -- vel ) + -- +.+ + -- (0.4 *.* vel) + reflV wall = (0.3 *.* reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0) + vel ) + +.+ + (0.2 *.* vel) + scaleChange | time < 80 = 3 + | otherwise = 3 - (fromIntegral time - 80) * 0.2 + g = _randGen w + tms = randomRs (15,20) g + scs = randomRs (0.1,0.5) g + (rs,g1) = runState ((sequence . take 5 . repeat . randInCirc) 20) $ _randGen w + f sc tm r = makeColorSmokeAt (greyN 0.3) (0.5 *.* vel) sc tm (ep +.+ r) + smokeGen w = set randGen g1 $ foldr ($) w (zipWith3 f scs tms rs) + + +flamerAngle = 0.3 + +aSelf :: Int -> World -> World +aSelf = blinkAction + +withAccVelWthHiteff' :: Float -> Point2 -> Float -> HitEffect' -> Int -> World -> World +withAccVelWthHiteff' acc vel width hiteff cid w + = over particles' ((:) newbul) + . over tempLightSources ((:) (tLightAt 4 pos)) + . lowLightAt pos2 + $ set randGen g + w + where cr = _creatures w IM.! cid + newbul = aGenBulAt' (Just cid) (numColor colid) pos (rotateV dir vel) hiteff width + (colid, g) = randomR (0,11) $ _randGen w + (a, _) = randomR (-acc,acc) $ _randGen w + dir = _crDir cr + a + pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr) + pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr) + +withOffsetAccVelWthHiteff' :: Float -> Float -> Point2 -> Float -> HitEffect' -> Int -> World -> World +withOffsetAccVelWthHiteff' offsetAmount acc vel width hiteff cid w + = over particles' ((:) newbul ) + $ muzFlareAt pos + $ set randGen g + w + where cr = _creatures w IM.! cid + newbul = aGenBulAt' (Just cid) (numColor colid) pos (rotateV dir vel) hiteff width + (colid, g) = randomR (0,11) $ _randGen w + (a, _) = randomR (-acc,acc) $ _randGen w + dir = _crDir cr + a + pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr) +.+ offset + (offsetVal , _) = randomR (-offsetAmount,offsetAmount) $ _randGen w + offset = rotateV (_crDir cr) (0,offsetVal) + +torqueBeforeForced :: Float -> (Int -> World -> World) -> Int -> World -> World +torqueBeforeForced torque feff cid w + | cid == 0 = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot') + $ over cameraRot (+rot') w + | otherwise = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot') w + where (rot, g) = randomR (-torque,torque) $ _randGen w + rot' | rot < 0 = rot - 0.1 + | otherwise = rot + 0.1 + +torqueBefore :: Float -> (Int -> World -> World) -> Int -> World -> World +torqueBefore torque feff cid w + | cid == 0 = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot) + $ over cameraRot (+rot) w + | otherwise = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot) w + where (rot, g) = randomR (-torque,torque) $ _randGen w + +torqueAfter :: Float -> (Int -> World -> World) -> Int -> World -> World +torqueAfter torque feff cid w + | cid == 0 = rotateScope $ set randGen g $ over cameraRot (+rot) $ feff cid w + | otherwise = set randGen g $ over (creatures . ix cid . crDir) (+rot) $ feff cid w + where (rot, g) = randomR (-torque,torque) $ _randGen w + rotateScope w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + . itAttachment . _Just . scopePos %~ rotateV rot + +aGenBulAt' :: Maybe Int -> Color -> Point2 -> Point2 -> HitEffect' -> Float -> Particle' +aGenBulAt' maycid col pos vel hiteff width = Bul' + { _ptPict' = blank + , _ptUpdate' = mvGenBullet' + , _btVel' = vel + , _btColor' = col + , _btTrail' = [pos] + , _btPassThrough' = maycid + , _btWidth' = width + , _btTimer' = 90 + , _btHitEffect' = hiteff + } + +-- bullet effects +bulHitCr' :: Particle' -> Point2 -> Creature -> World -> World +bulHitCr' bt p cr w = + let sp = head $ _btTrail' bt + ep = sp +.+ _btVel' bt + -- mvDams = [TorqueDam 1 d1 , PushDam 1 $ 2 *.* (ep -.- sp) ] + mvDams = [ PushDam 1 $ 2 *.* (ep -.- sp) ] + addDamage = over (creatures . ix cid . crState . crDamage) + (\dams -> (Piercing 100 sp p ep : mvDams) ++ dams) + addDamageArmoured = over (creatures . ix cid . crState . crDamage) + (\dams -> mvDams ++ dams) + hitSound = soundMultiFrom [CrHitSound 0] 15 10 0 + flashEff = over worldEvents ((.) $ flareAt red p) + bulVel = ep -.- sp + ck cid = (+.+) (crKnockBack cid *.* bulVel) + crKnockBack cid = (/) 1 $ (+) 2 $ _crMass $ _creatures w IM.! cid + hasArmour cr = any (\it -> it ^? itIdentity == Just FrontArmour) $ _crInv cr + cid = _crID cr + sID = newParticleKey w + (d1,g) = randomR (-0.7,0.7) $ _randGen w + (colID,_) = randomR (0,11) $ _randGen w + hitEffect = addDamage . hitSound . flashEff $ w + in case hasArmour cr of --shit this is ugly, to refactor + True -> if hitBack + then hitEffect + else createSpark 8 colID p1 + (argV (p -.- _crPos (_creatures w IM.! cid)) + d1) + Nothing + . addDamageArmoured + $ w + where cpos = _crPos $ _creatures w IM.! cid + relHitPos = p -.- cpos + hitBack = errorAngleVV 19 (unitVectorAtAngle (_crDir $ _creatures w IM.! cid)) + relHitPos + > pi/2 + p1 = p +.+ 2 *.* safeNormalizeV relHitPos + _ -> hitEffect + +bulPenCr' :: Particle' -> Point2 -> Creature -> World -> World +bulPenCr' bt p cr w + = over (creatures . ix cid . crState . crDamage) + (\dams -> [Piercing 50 sp p ep + ,Blunt 50 sp p ep + ,TorqueDam 1 d1 + ,PushDam 1 $ 3 *.* (ep -.- sp) + ] ++ dams + ) + $ soundMultiFrom [CrHitSound 0] 15 10 0 + $ over worldEvents addPiercer + w + where (d1,g) = randomR (-0.7,0.7) $ _randGen w + cid = _crID cr + sp = head $ _btTrail' bt + ep = sp +.+ _btVel' bt + addPiercer = (.) $ over particles' ((:) piercer) + piercer = (aGenBulAt' (Just cid) (_btColor' bt) p (_btVel' bt) + (_btHitEffect' bt) (_btWidth' bt) + ) {_btTimer' = _btTimer' bt - 1} + +hvBulHitCr' :: Particle' -> Point2 -> Creature -> World -> World +hvBulHitCr' bt p cr w + = over (creatures . ix cid . crState . crDamage) + (\dams -> [Piercing 200 sp p ep + ,Blunt 100 sp p ep + ,TorqueDam 1 d1 + ,PushDam 1 $ 3 *.* (ep -.- sp) + ] ++ dams + ) + $ soundMultiFrom [CrHitSound 0] 15 10 0 + w + where (d1,g) = randomR (-0.7,0.7) $ _randGen w + cid = _crID cr + sp = head $ _btTrail' bt + ep = sp +.+ _btVel' bt + +bulIncCr' :: Particle' -> Point2 -> Creature -> World -> World +bulIncCr' bt p cr w + = over (creatures . ix cid . crState . crDamage) + (\dams -> [Piercing 60 sp p ep + ] ++ dams + ) + $ soundMultiFrom [CrHitSound 0] 15 10 0 + $ incFlamelets + w + where cid = _crID cr + sp = head $ _btTrail' bt + ep = sp +.+ _btVel' bt + v = evalState (randInCirc 1) $ _randGen w + incFlamelets = over worldEvents $ (.) (makeFlamelet p v (levLayer UPtLayer) Nothing 3) + +bulConCr' :: Particle' -> Point2 -> Creature -> World -> World +bulConCr' bt p cr w + = over (creatures . ix cid . crState . crDamage) + (\dams -> [Piercing 60 sp p ep + ] ++ dams + ) + $ soundMultiFrom [CrHitSound 0] 15 10 0 + $ mkwave + w + where cid = _crID cr + sp = head $ _btTrail' bt + ep = sp +.+ _btVel' bt + mkwave = over worldEvents $ (.) (makeShockwaveAt p 15 4 1 white) + + + +bulHitWall' :: Particle' -> Point2 -> Wall -> World -> World +bulHitWall' bt p x w = damageBlocks x + $ createSpark 8 colID pOut (reflectDir x) Nothing + $ set randGen g + w + where sp = head $ _btTrail' bt + pOut = p +.+ safeNormalizeV (sp -.- p) + (colID,g) = randomR (0,11) $ _randGen w + (a, _) = randomR (-0.1,0.1) $ _randGen w + spid = newKey $ _particles w + reflectDir wall = a + (argV $ reflectIn + (_wlLine wall !! 1 -.- _wlLine wall !! 0) + (p -.- sp) + ) + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall) + _ -> w + +bulBounceWall' :: Particle' -> Point2 -> Wall -> World -> World +bulBounceWall' bt p wl w = damageBlocks wl + $ over worldEvents addBouncer + -- yay for hack -- should have used this before? or never? + w + where sp = head $ _btTrail' bt + pOut = p +.+ safeNormalizeV (sp -.- p) + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall) + _ -> w + bouncer = (aGenBulAt' Nothing (_btColor' bt) pOut reflectVel + (_btHitEffect' bt) (_btWidth' bt) + ) {_btTimer' = _btTimer' bt - 1} + wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0) + reflectVel = (reflectIn wallV (_btVel' bt)) + addBouncer = (.) (over particles' ((:) bouncer)) +-- the hack is to get around the fact that the particles' list gets reset after +-- all particles in it are checked, so we cannot add to it as we accumulate over +-- this list + +bulIncWall' :: Particle' -> Point2 -> Wall -> World -> World +bulIncWall' bt p wl w = damageBlocks wl + $ incFlamelets + -- yay for hack -- should have used this before? or never? + w + where sp = head $ _btTrail' bt + pOut = p +.+ safeNormalizeV (sp -.- p) + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall) + _ -> w + wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0) + reflectVel = safeNormalizeV $ reflectIn wallV (_btVel' bt) + incFlamelets = over worldEvents $ (.) (makeFlamelet pOut reflectVel (levLayer UPtLayer) Nothing 3) + +bulConWall' :: Particle' -> Point2 -> Wall -> World -> World +bulConWall' bt p wl w = damageBlocks wl + $ mkwave + -- yay for hack -- should have used this before? or never? + w + where sp = head $ _btTrail' bt + pOut = p +.+ safeNormalizeV (sp -.- p) + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall) + _ -> w + wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0) + mkwave = over worldEvents $ (.) (makeShockwaveAt p 15 4 1 white) + +hvBulHitWall' :: Particle' -> Point2 -> Wall -> World -> World +hvBulHitWall' bt p x w = damageBlocks x + $ set randGen g + $ foldr ($) w (sparks pOut sv) + where sp = head $ _btTrail' bt + pOut = p +.+ safeNormalizeV (sp -.- p) + (a, g) = randomR (-0.1,0.1) $ _randGen w + spid = newKey $ _particles w + reflectDir wall = a + (argV $ reflectIn + (_wlLine wall !! 1 -.- _wlLine wall !! 0) + (p -.- sp) + ) + sv = unitVectorAtAngle $ reflectDir x + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 20)) w (_blIDs wall) + _ -> w + sID = newParticleKey w + cs = take 10 $ randomRs (0,11) $ _randGen w + ds = randomRs (-0.7,0.7) $ _randGen w + ts = randomRs (4,8) $ _randGen w + sparks pos vel = zipWith3 (\t c d -> createSpark t c pos (argV vel + d) Nothing) ts cs ds +bulHitFF' :: Particle' -> Point2 -> ForceField -> World -> World +bulHitFF' _ _ _ = id + +bulletEffect' :: HitEffect' +bulletEffect' = threeEff' bulHitCr' bulHitWall' bulHitFF' + +bulletParticleSideEffect :: Particle' -> HitEffect' +bulletParticleSideEffect pt = threeEff' mkPt mkPt noEff + where mkPt _ p _ = over particles' ((:) pt {_btTrail' = [p]}) + +reflect :: Float -> Float -> Float +reflect a b = a + 2*(a-b) + +moveGrenade :: Int -> Float -> Int -> World -> World +moveGrenade 0 dir pID w = over particles (IM.delete pID) + $ makeExplosionAt (_ptPos (_particles w IM.! pID)) + -- $ set (pointToItem (_itemPositions w IM.! wpID) . itEquipPict) + -- (drawWeapon $ grenadePic 50) + w +moveGrenade time dir pID w + = case hitWl of + Just _ -> soundOnce (fromIntegral tapQuiet) updatedWorld + _ -> updatedWorld + where + updatedWorld = updateV $ set (particles . ix pID . ptPos) finalPos + $ set (particles.ix pID.ptPict) + (onLayer PtLayer $ uncurry translate newPos + $ rotate dir $ grenadePic time) + $ set (particles.ix pID.ptUpdate) (moveGrenade (time-1) dir pID) w + pt = _particles w IM.! pID + oldPos = _ptPos pt + newPos = _ptVel pt +.+ oldPos + hitWl = collideCircWalls' oldPos newPos 4 $ wallsNearPoint newPos w + finalPos = fromMaybe newPos (fmap fst hitWl) + setV v = set (particles.ix pID.ptVel) v + updateV = fromMaybe id (fmap (setV.snd) hitWl) + +pointToItem (InInv cid invid) = creatures . ix cid . crInv . ix invid +pointToItem (OnFloor flid) = floorItems . ix flid . flIt + +retireRemoteRocket :: Int -> Int -> Int -> World -> World +retireRemoteRocket itid 0 ptid w + = set (pointToItem (_itemPositions w IM.! itid) . itAttachment . _Just . scopePos) + (0,0) + $ set (pointToItem (_itemPositions w IM.! itid) . wpFire) + fireRemoteLauncher + (w & particles %~ IM.delete ptid) +retireRemoteRocket itid t ptid w = setScope w & particles . ix ptid . ptUpdate .~ retireRemoteRocket itid (t-1) ptid + where + setScope w' = case _itemPositions w' IM.! itid of + InInv cid invid + -> w' & creatures . ix cid . crInv . ix invid . itAttachment + . _Just . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid)) + _ -> w' + pos = fromMaybe (0,0) $ w ^? particles . ix ptid . ptPos + +retireRemoteBomb :: Int -> Int -> Int -> World -> World +retireRemoteBomb itid 0 ptid w + = set (pointToItem (_itemPositions w IM.! itid) . itAttachment . _Just . scopePos) + (0,0) + $ set (pointToItem (_itemPositions w IM.! itid) . itZoom) + basicItZoom + $ set (pointToItem (_itemPositions w IM.! itid) . twFire) + throwRemoteBomb + (w & particles %~ IM.delete ptid) +retireRemoteBomb itid t ptid w + = setScope w & particles . ix ptid . ptUpdate .~ retireRemoteBomb itid (t-1) ptid + where + setScope w' = case _itemPositions w' IM.! itid of + InInv cid invid + -> w' & creatures . ix cid . crInv . ix invid . itAttachment + . _Just . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid)) + _ -> w' + pos = fromMaybe (0,0) $ w ^? particles . ix ptid . ptPos + +moveRemoteBomb :: Int -> Int -> Int -> World -> World +moveRemoteBomb itid time pID w + | time < -4 = setScope + $ updatePicture + $ set (particles.ix pID.ptUpdate) (moveRemoteBomb itid (f time) pID) + w + | time < 2 + = case hitWl of + Just _ -> soundOnce (fromIntegral tapQuiet) $ halfV updatedWorld + _ -> halfV updatedWorld + | otherwise + = case hitWl of + Just _ -> soundOnce (fromIntegral tapQuiet) updatedWorld + _ -> updatedWorld + where + updatedWorld + = updateV $ set (particles . ix pID . ptPos) finalPos + $ updatePicture + $ set (particles.ix pID.ptUpdate) (moveRemoteBomb itid (time-1) pID) + $ setScope + w + setScope w' = case _itemPositions w' IM.! itid of + InInv cid invid + -> w' & creatures . ix cid . crInv . ix invid . itAttachment + . _Just . scopePos .~ (newPos -.- _crPos (_creatures w' IM.! cid)) + & creatures . ix cid . crInv . ix invid . itZoom + .~ (basicItZoom {_itAimZoomMax = 0.5, _itAimZoomMin = 0.5}) + _ -> w' + pt = _particles w IM.! pID + oldPos = _ptPos pt + newPos = _ptVel pt +.+ oldPos +-- this is hacky, should use a version of collidePointWalls' that collides +-- circles and walls + invShift x = x -.- 5 *.* normalizeV (_ptVel pt) + hitWl = collideCircWalls' oldPos newPos 4 $ wallsNearPoint newPos w + finalPos = fromMaybe newPos (fmap (invShift . fst) hitWl) + setV v = set (particles.ix pID.ptVel) v + updateV = fromMaybe id (fmap (setV.snd) hitWl) + halfV = over (particles . ix pID . ptVel) (\v -> 0.5 *.* v) + f x | x < -369 = -10 + | otherwise = x - 1 + updatePicture = set (particles . ix pID.ptPict) + (onLayer PtLayer $ uncurry translate newPos + $ remoteBombPic time) + . lowLightDirected red 0.1 newPos + (50 *.* unitVectorAtAngle (negate $ degToRad (10 * fromIntegral time))) + [-0.2,-0.15,-0.1,-0.05,0,0.05,0.1,0.15,0.2] + + +shootRateIncrease :: Int -> Int -> (Int -> World -> World) -> Int -> World -> World +shootRateIncrease startRate fastRate shootEffect cid w + | repeatFire = set (pointItem . wpFireRate) (max fastRate (currentRate - 1)) + $ set (pointItem . wpFireState) currentRate + $ shootEffect cid + w + | firstFire = set (pointItem . wpFireRate) (startRate - 1) + $ set (pointItem . wpFireState) startRate + $ shootEffect cid + w + | reloadCondition = fromMaybe w $ reloadWeapon cid w + | otherwise = w + where cr = _creatures w IM.! cid + itRef = _crInvSel cr + item = _crInv cr IM.! itRef + pointItem = (creatures . ix cid . crInv . ix itRef) + currentRate = _wpFireRate item + repeatFire = _wpReloadState item == 0 + && _wpFireState item == 1 + && _wpLoadedAmmo item > 0 + firstFire = _wpReloadState item == 0 + && _wpFireState item == 0 + && _wpLoadedAmmo item > 0 + reloadCondition = _wpLoadedAmmo item == 0 + +rateIncAB :: Int -> Int -> (Int -> World -> World) + -> (Int -> World -> World) + -> Int -> World -> World +rateIncAB startRate fastRate shooteff1 shooteff2 cid w + | repeatFire = set (pointItem . wpFireRate) (max fastRate (currentRate - 1)) + $ over (pointItem . wpLoadedAmmo) (\ammo -> ammo-1) + $ set (pointItem . wpFireState) currentRate + $ shooteff2 cid + w + | firstFire = set (pointItem . wpFireRate) (startRate - 1) + $ over (pointItem . wpLoadedAmmo) (\ammo -> ammo-1) + $ set (pointItem . wpFireState) startRate + $ shooteff1 cid + w + | reloadCondition = fromMaybe w $ reloadWeapon cid w + | otherwise = w + where cr = _creatures w IM.! cid + itRef = _crInvSel cr + item = _crInv cr IM.! itRef + pointItem = (creatures . ix cid . crInv . ix itRef) + currentRate = _wpFireRate item + repeatFire = _wpReloadState item == 0 + && _wpFireState item == 1 + && _wpLoadedAmmo item > 0 + firstFire = _wpReloadState item == 0 + && _wpFireState item == 0 + && _wpLoadedAmmo item > 0 + reloadCondition = _wpLoadedAmmo item == 0 + + +withThinSmoke :: (Int -> World -> World) -> Int -> World -> World +withThinSmoke eff cid w = eff cid $ foldr ($) w smokeGen + where + cr = _creatures w IM.! cid + dir = _crDir cr + pos = _crPos cr +.+ ((_crRad cr +0.5) *.* unitVectorAtAngle dir) + (vs,_) = runState ((sequence . repeat . randInCirc) 0.4) $ _randGen w + (sps,_) = runState ((sequence . repeat . randInCirc) 8) $ _randGen w + ts = randomRs (250,1000) $ _randGen w + ss = take 3 $ randomRs (10,20) $ _randGen w + smokeGen = zipWith4 (\ v s t sp -> makeThinSmokeAt (greyN 0.1) v s t (pos +.+ sp)) + vs ss ts sps + +withThickSmoke :: (Int -> World -> World) -> Int -> World -> World +withThickSmoke eff cid w = eff cid $ foldr ($) w smokeGen + where + cr = _creatures w IM.! cid + dir = _crDir cr + pos = _crPos cr +.+ ((_crRad cr +0.5) *.* unitVectorAtAngle dir) + (vs,_) = runState ((sequence . repeat . randInCirc) 0.4) $ _randGen w + (sps,_) = runState ((sequence . repeat . randInCirc) 8) $ _randGen w + ts = randomRs (18,20) $ _randGen w + ss = take 20 $ randomRs (0.1,1) $ _randGen w + smokeGen = zipWith4 (\ v s t sp -> makeColorSmokeAt (greyN 0.1) v s t (pos +.+ sp)) + vs ss ts sps + + +makeThinSmokeAt :: Color -> Point2 -> Float -> Int -> Point2 -> World -> World +makeThinSmokeAt col vel scal time p w = over particles (IM.insert n smP) w + where n = newParticleKey w + smP = Particle + { _ptPos = p + , _ptStartPos = p + , _ptVel = vel + , _ptPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 1 + , _ptID = n + , _ptUpdate = moveThinSmoke col scal time n + } + +moveThinSmoke :: Color -> Float -> Int -> Int -> World -> World +moveThinSmoke col scal time i w + | time > 0 + = set (particles . ix i . ptPict) pic + . set (particles . ix i . ptUpdate) (moveThinSmoke col scal (time-1) i) + . set (particles . ix i . ptPos) newPos + . setVel + $ w + | time > -10 + = set (particles . ix i . ptPict) pi1 + . set (particles . ix i . ptUpdate) (moveThinSmoke col scal (time-1) i) + . set (particles . ix i . ptPos) newPos + . setVel + $ w + | otherwise + = over particles (IM.delete i) w + where oldPos = _ptPos $ _particles w IM.! i + newPos = oldPos +.+ (_ptVel $ _particles w IM.! i) + setVel = over (particles . ix i . ptVel) $ (*.*) 0.99 + pic = onLayer PtLayer $ uncurry translate newPos $ color (withAlpha 0.1 col) $ circleSolid scal + pi1 = onLayer PtLayer $ uncurry translate newPos + $ color (withAlpha (0.1 + fromIntegral time /100) col) + $ circleSolid $ scal + +makeLaserAt :: Float -> Point2 -> Float -> Maybe Int -> Particle' +makeLaserAt phaseV pos dir mcid = Particle' + { _ptPict' = blank + , _ptUpdate' = moveLaser phaseV pos dir mcid + } + +moveLaser :: Float -> Point2 -> Float -> Maybe Int -> World -> Particle' -> (World, Maybe Particle') +moveLaser phaseV pos dir mcid w pt + = ( set randGen g $ over worldEvents ((.) flares) $ hitSpecific w + , Just pt {_ptPict' = onLayer PtLayer $ pic + ,_ptUpdate' = ptTimer' 0 + } + ) + where sp = pos + xp = sp +.+ 800 *.* unitVectorAtAngle dir + --thHit = listToMaybe $ filter notSeeThrough $ thingsHitExceptCrLongLine mcid sp xp w + (a,g) = randomR (-0.7,0.7) $ _randGen w + reflectDir wall = a + (argV $ reflectIn + (_wlLine wall !! 1 -.- _wlLine wall !! 0) + (xp -.- sp) + ) + notSeeThrough (p,E3x2 wl) = not $ _wlIsSeeThrough wl + notSeeThrough _ = True + (colID,_) = randomR (0,11) $ _randGen w + flares w = foldr (\p w' -> flareAt' yellow 0.01 0.02 p w') w flarePs + flarePs = zipWith (\x y -> x +.+ 5 *.* normalizeV (y -.- x)) ps $ tail ps + flarePos p = p +.+ ((a + 0.8) * 3) *.* (normalizeV (sp -.- p)) + f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either3 Creature Wall ForceField),[Point2]) + f seenWs x y = case listToMaybe $ filter (h' seenWs) + $ thingsHitExceptCrLongLine Nothing x y w of + Just (p,E3x2 wl) + | _wlIsSeeThrough wl -> f' p $ f (wl:seenWs) + p + (h x y wl p) + | otherwise -> (Just (p,E3x2 wl), [p]) + Just (p,obj) -> (Just (p,obj), [p]) + Nothing -> (Nothing, [y]) + f' p (x,ps') = (x,p:ps') + h x y wl p | isEntering = p +.+ rotateV angleRef normalDist + | otherwise = p +.+ rotateV angleRef' normalDist' + where wlNormal = vNormal $ (_wlLine wl !! 1) -.- (_wlLine wl !! 0) + normalDist = magV (p -.- y) *.* normalizeV wlNormal + angleInc = piRange $ argV wlNormal - argV (x -.- y) + angleRef | reflectExternal = angleInc + | otherwise = asin $ sin angleInc / phaseV + piRange a | a > pi = a - 2 * pi + | a > 0 - pi = a + | otherwise = a + 2 * pi + isEntering = isLeftOf (x -.- y) ((_wlLine wl !! 1) -.- (_wlLine wl !! 0)) + wlNormal' = vNormal $ (_wlLine wl !! 0) -.- (_wlLine wl !! 1) + normalDist' = magV (p -.- y) *.* normalizeV wlNormal' + angleInc' = piRange $ argV wlNormal' - argV (x -.- y) + angleRef' | reflectInternal = angleInc' + | otherwise = asin $ phaseV * sin angleInc' + reflectInternal = 1 < abs (phaseV * sin angleInc') + reflectExternal = 1 < abs (sin angleInc / phaseV) + + h' ws (_,E3x2 wl) = not $ any (\w -> _wlID w == _wlID wl) ws + h' _ _ = True + (thHit, ps) = f [] sp xp + hitSpecific + = case thHit of + Just (p,E3x1 cr) + -> over (creatures . ix (_crID cr) . crState . crDamage) ((:) $ Lasering 3 sp p xp) + . over worldEvents ((.) $ flareAt yellow (flarePos p)) + Just (p,E3x2 wl) -> createSpark 8 colID (p +.+ safeNormalizeV (sp -.- p)) + (reflectDir wl) Nothing + _ -> id + pic = case thHit of + Nothing -> + pictures [color (withAlpha 0.05 yellow) $ lineOfThickness (a*20+40) (sp:ps) + ,color (withAlpha 0.3 yellow) $ vvThickLine (sp:ps) + ,color (withAlpha 0.9 white) $ vThickLine (sp:ps) + ,fadeLine lp op 0.9 3 white + ,fadeLine lp op 0.3 3 yellow + ,fadeLine lp op 0.05 (a*20+40) yellow + ] + _ -> + pictures [color (withAlpha 0.05 yellow) $ lineOfThickness (a*20+40) (sp:ps) + ,color (withAlpha 0.3 yellow) $ vvThickLine (sp:ps) + ,color (withAlpha 0.9 white) $ vThickLine (sp:ps) + ] + where lp = last ps + lp' = last $ init (sp:ps) + op = lp +.+ 50 *.* normalizeV (lp -.- lp') + +fadeLine :: Point2 -> Point2 -> Float -> Float -> Color -> Picture +fadeLine sp ep alph width col = + pictures [color (withAlpha (0.8 * alph) col) $ lineOfThickness width [sp,p 0.25] + ,color (withAlpha (0.6 * alph) col) $ lineOfThickness width [p 0.25,p 0.5] + ,color (withAlpha (0.4 * alph) col) $ lineOfThickness width [p 0.5,p 0.75] + ,color (withAlpha (0.2 * alph) col) $ lineOfThickness width [p 0.75,ep] + ] + where p x = sp +.+ x *.* (ep -.- sp) + +closestOfThree :: Point2 -> Maybe (Point2,a) -> Maybe (Point2,b) -> Maybe (Point2,c) + -> Maybe (Point2, Either3 a b c) +closestOfThree p x1 x2 x3 = listToMaybe $ sortBy g $ catMaybes [fmap f1 x1,fmap f2 x2,fmap f3 x3] + where f1 (r1,s1) = (r1, E3x1 s1) + f2 (r2,s2) = (r2, E3x2 s2) + f3 (r3,s3) = (r3, E3x3 s3) + g (x,_) (y,_) = compare (magV (x -.- p)) (magV (y -.- p)) + +grenadeLauncher :: Item +grenadeLauncher = pistol + +grenade,remoteBomb :: Item +grenade = Throwable + { _itName = "grenade " ++ show fuseTime + , _itIdentity = Grenade + , _itMaxStack = 8 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _twMaxRange = 150 + , _twAccuracy = 30 + , _twFire = throwGrenade fuseTime + , _itAimingSpeed = 1 + , _itAimingRange = 0 + , _itZoom = basicItZoom {_itAimZoomMax = (f fuseTime), _itAimZoomMin = (f fuseTime)} + , _itEquipPict = drawWeapon $ grenadePic fuseTime + , _itID = Nothing + , _itAttachment = Just $ ItFuse fuseTime + , _itInvColor = white + , _itInvDisplay = _itName + , _itEffect = wpRecock + , _itHammer = HammerUp + , _itScrollUp = decreaseFuse fuseTime + , _itScrollDown = increaseFuse fuseTime + } + where fuseTime = 50 + f x = 50 / fromIntegral x +increaseFuse :: Int -> Int -> World -> World +increaseFuse fuse i w = w & creatures . ix 0 . crInv . ix itRef . itScrollUp .~ decreaseFuse newTime + & creatures . ix 0 . crInv . ix itRef . itScrollDown .~ increaseFuse newTime + & creatures . ix 0 . crInv . ix itRef . twFire .~ throwGrenade newTime + & creatures . ix 0 . crInv . ix itRef . itName .~ "grenade " ++ show newTime + & creatures . ix 0 . crInv . ix itRef . itAttachment .~ Just (ItFuse newTime) + & creatures . ix 0 . crInv . ix itRef . itZoom + .~ (basicItZoom {_itAimZoomMax = zm, _itAimZoomMin = zm}) + where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel + newTime = min (fuse + 5) 90 + zm = 50 / fromIntegral newTime + +decreaseFuse :: Int -> Int -> World -> World +decreaseFuse fuse i w = w & creatures . ix 0 . crInv . ix itRef . itScrollUp .~ decreaseFuse newTime + & creatures . ix 0 . crInv . ix itRef . itScrollDown .~ increaseFuse newTime + & creatures . ix 0 . crInv . ix itRef . twFire .~ throwGrenade newTime + & creatures . ix 0 . crInv . ix itRef . itName .~ "grenade " ++ show newTime + & creatures . ix 0 . crInv . ix itRef . itAttachment .~ Just (ItFuse newTime) + & creatures . ix 0 . crInv . ix itRef . itZoom + .~ (basicItZoom {_itAimZoomMax = zm, _itAimZoomMin = zm}) + where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel + newTime = max (fuse - 5) 20 + zm = 50 / fromIntegral newTime + +defaultThrowable = grenade +remoteBomb = defaultThrowable + { _itName = "remoteBomb" + , _itIdentity = RemoteBomb + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _twMaxRange = 150 + , _twAccuracy = 30 + , _twFire = throwRemoteBomb + , _itAttachment = Just $ ItScope (0,0) 0 1 True + , _itEquipPict = drawWeapon $ remoteBombUnarmedPic + } + + +throwGrenade :: Int -> Int -> World -> World +--throwGrenade n w = rmInvItem n $ over particles addG $ set randGen g w +throwGrenade fuseTime n w = setWp $ removePict $ over particles addG $ set randGen g w + where addG = IM.insert i + $ Particle { _ptPos = p + , _ptStartPos = p + , _ptVel = v + , _ptPict = onLayer PtLayer $ uncurry translate p $ grenadePic 0 + , _ptID = i + , _ptUpdate = moveGrenade fuseTime dir i + } + j = _crInvSel $ _creatures w IM.! n + removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank + i = newParticleKey w + (a, g) = randomR (-grenadeAccA,grenadeAccA::Float) (_randGen w) + (l, _) = randomR (1 - 2*grenadeAccL,1+grenadeAccL::Float) g + -- v = 0.02 * l / _cameraZoom w *.* rotateV (a+_cameraRot w) (limitRange $ _mousePos w) + v' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w) + v | magV v' > 6 = 6 *.* normalizeV v' + | otherwise = v' + cr = _creatures w IM.! n + p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0) + p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0) + | otherwise = p' + dir = negate $ radToDeg $ argV $ v + setWp :: World -> World + setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20 + --maybewpid = w ^? creatures . ix n . crInv . ix j . itID . _Just + --setWpLocation :: World -> World + --setWpLocation w' = case maybewpid of + -- Nothing -> w' & creatures . ix n . crInv . ix j . itID .~ Just newitid + -- & itemPositions %~ IM.insert newitid (InInv n j) + -- _ -> w' + --newitid = newKey $ _itemPositions w + --wpid = fromMaybe newitid maybewpid + +throwArmReset :: Int -> ItEffect +throwArmReset x = + ItInvEffect {_itInvEffect = f + ,_itEffectCounter = x + } + where f cr i = creatures . ix (_crID cr) . crInv %~ IM.adjust counterDown i + counterDown it | _itEffectCounter (_itEffect it) == 0 + = it & itHammer .~ HammerUp + & itEquipPict .~ (drawWeapon $ grenadePic 50) + | otherwise = it & itEffect . itEffectCounter %~ (\x -> x - 1) + +(grenadeAccL, grenadeAccA) = (0.1, 0.1) + +grenadePic :: Int -> Picture +grenadePic x = pictures [ color (dark $ dark green) $ circleSolid 5 + , color green $ arc + ((179 * fromIntegral x / 50) - 180 ) + (180 - (179 * fromIntegral x / 50) ) + 5 + , translate (-2) 2 $ rotate 90 + $ scale 0.05 0.05 $ color green $ text $ show $ 1 + quot x 20 + ] + +fireRemoteLauncher :: Int -> World -> World +fireRemoteLauncher cid w = setLocation $ resetFire $ resetName + $ soundOnce (fromIntegral launcherSound) + $ over particles remRocket w + where + i = newKey $ _particles w + cr = _creatures w IM.! cid + dir = _crDir cr + pos = _crPos cr +.+ rotateV dir (_crRad cr + 1,0) + remRocket = IM.insert i $ Particle { _ptPos = pos + , _ptStartPos = pos + , _ptVel = rotateV dir (1,0) + , _ptPict = blank + , _ptID = i + , _ptUpdate = moveRemoteShell 50 i cid itid dir + } + j = _crInvSel $ _creatures w IM.! cid + newitid = newKey $ _itemPositions w + maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just + resetFire = set (creatures . ix cid . crInv . ix j . wpFire) $ explodeRemoteRocket itid i + resetName = set (creatures . ix cid . crInv . ix j . itName) "remoteRocket" + setLocation :: World -> World + setLocation w' = case maybeitid of + Nothing -> w' & creatures . ix cid . crInv . ix j . itID .~ Just newitid + & itemPositions %~ IM.insert newitid (InInv cid j) + _ -> w' + itid = fromMaybe newitid maybeitid + +moveRemoteShell :: Int -> Int -> Int -> Int -> Float -> World -> World +moveRemoteShell time i cid itid dir w + | time > 40 = if circOnSomeWall oldPos 4 w + then doExplosion w + else over (particles . ix i . ptPos) (+.+ vel) + $ set (particles . ix i . ptPict) piclow + $ set (particles . ix i . ptUpdate) + (moveRemoteShell (time-1) i cid itid newdir) + $ setScope + w + | time >= 20 = case thingHit of + Just p -> doExplosion w + Nothing -> over (particles . ix i . ptPos) (+.+ vel) + $ set (particles . ix i . ptPict) pic + $ set (particles . ix i . ptUpdate) + (moveRemoteShell (time-1) i cid itid newdir) + $ setScope + w + | time > -99 + = case thingHit of + Just p -> doExplosion + $ stopSoundFrom (ShellSound i) + w + Nothing -> over (particles . ix i . ptPos) (+.+ vel) + $ set randGen g + $ set (particles . ix i . ptPict) pic + $ set (particles . ix i . ptUpdate) + (moveRemoteShell (time-1) i cid itid newdir) + $ over (particles . ix i . ptVel) (\v -> accel +.+ frict *.* v) + $ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250 + $ smokeGen + $ makeFlameletTimed oldPos + (0.5 *.* rotateV (pi+sparkD) accel) (levLayer UPtLayer) Nothing 3 20 + $ makeFlameletTimed (0.5 *.* (newPos +.+ oldPos)) + (0.5 *.* rotateV (pi+sparkD) accel) (levLayer UPtLayer) Nothing 3 20 + $ setScope + w + | time > -200 = case thingHit of + Just p -> doExplosion + $ stopSoundFrom (ShellSound i) + w + Nothing -> over (particles . ix i . ptPos) (+.+ vel) + $ set (particles . ix i . ptPict) pic + $ set (particles . ix i . ptUpdate) + (moveRemoteShell (time-1) i cid itid newdir) + $ setScope + w + | otherwise = doExplosion + $ stopSoundFrom (ShellSound i) + w + where pt = _particles w IM.! i + oldPos = _ptPos pt + vel = _ptVel pt + newPos = oldPos +.+ vel + newdir + | SDL.ButtonRight `S.member` (_mouseButtons w) + && w ^? creatures . ix cid . crInvSel == w ^? itemPositions . ix itid . itInvId + = _cameraRot w + (argV $ _mousePos w) + | otherwise = dir + accel = rotateV newdir (2,0) + (frict,g) = randomR (0.6,0.9) $ _randGen w + (sparkD,_) = randomR (-0.5,0.5) $ _randGen w + dir = argV $ vel + pic = onLayer PtLayer $ uncurry translate newPos + $ rotate (-radToDeg (argV accel)) $ remoteShellPic time + piclow = onLayerL [levLayer CrLayer - 2] + $ uncurry translate newPos $ rotate (-radToDeg (argV accel)) + $ remoteShellPic time + hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w + hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w + thingHit = hitCr <|> hitWl + + (v1:v2:v3:_) = fst $ runState ((sequence . repeat . randInCirc) 0.1) $ _randGen w + (r1:r2:r3:_) = map ((*.*) 100) (v2:v3:v1:[]) + (t1:t2:t3:_) = randomRs ( 15,20) $ _randGen w + (s1:s2:s3:_) = map (\s -> fromIntegral s * 0.1 - 1) (t3:t2:t1:[]) + -- ((r1:r2:r3:_),_) = runState ((sequence . repeat . randInCirc) 10) $ _randGen w + -- v1 = fst $ runState (randInCirc 0.5) $ _randGen w + smokeGen = makeSmokeAt'' v1 s1 t1 (newPos +.+ r1) + . makeSmokeAt'' v2 s2 t2 (newPos +.+ r2) + -- . makeSmokeAt'' v3 s3 t3 (newPos +.+ r3) + doExplosion = explodeRemoteRocket itid i cid + setScope w' = case _itemPositions w' IM.! itid of + InInv cid invid + -> w' & creatures . ix cid . crInv . ix invid . itAttachment + . _Just . scopePos .~ (newPos -.- _crPos (_creatures w' IM.! cid)) + _ -> w' + +explodeRemoteRocket :: Int -> Int -> Int -> World -> World +explodeRemoteRocket itid ptid n w + = set (particles . ix ptid . ptUpdate) (retireRemoteRocket itid 30 ptid) + $ set (particles . ix ptid . ptPict) blank + $ set (itPoint . wpFire) (flip const) + $ resetName +-- $ resetScope + $ makeExplosionAt (_ptPos (_particles w IM.! ptid)) w + -- $ makeShrapnelBombAt (_ptPos (_particles w IM.! ptid)) w + where resetName = set (itPoint . itName) "remoteLauncher" +-- resetScope = creatures . ix n . crInv . ix j . itScope . _Just . scopePos .~ (0,0) + itPoint = pointToItem $ _itemPositions w IM.! itid + +throwRemoteBomb :: Int -> World -> World +throwRemoteBomb n w = setLocation $ removePict $ resetFire + -- $ resetName $ over particles addG $ set randGen g w + $ resetName $ over particles addG w + where addG = IM.insert i + $ Particle { _ptPos = p + , _ptStartPos = p + , _ptVel = v + , _ptPict = blank + , _ptID = i + , _ptUpdate = moveRemoteBomb itid 50 i + } + i = newParticleKey w + -- fireDist = zoom *.* (rotateV (_cameraRot w) (_mousePos w) +.+ _cameraPos w -.- yourPos) + d = argV $ _mousePos w + --(l, _) = randomR (1 - grenadeAccL,1+grenadeAccL) (_randGen w) + --(a, g) = randomR (-grenadeAccA,grenadeAccA) (_randGen w) + v' = 0.02 / _cameraZoom w *.* rotateV (_cameraRot w) ( _mousePos w) + v | magV v' > 6 = 6 *.* normalizeV v' + -- zoom = 1 / _cameraZoom w + j = _crInvSel $ _creatures w IM.! n + resetName = set (creatures . ix n . crInv . ix j . itName) "remote" + removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank + resetFire = set (creatures . ix n . crInv . ix j . twFire) $ explodeRemoteBomb itid i + cr = _creatures w IM.! n + p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0) + p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0) + | otherwise = p' + maybeitid = w ^? creatures . ix n . crInv . ix j . itID . _Just + setLocation :: World -> World + setLocation w' = case maybeitid of + Nothing -> w' & creatures . ix n . crInv . ix j . itID .~ Just newitid + & itemPositions %~ IM.insert newitid (InInv n j) + _ -> w' + newitid = newKey $ _itemPositions w + itid = fromMaybe newitid maybeitid + + +explodeRemoteBomb :: Int -> Int -> Int -> World -> World +explodeRemoteBomb itid ptid n w + = set (particles . ix ptid . ptUpdate) (retireRemoteBomb itid 30 ptid) + $ set (particles . ix ptid . ptPict) blank + $ set (creatures . ix n . crInv . ix j . twFire) (flip const) + $ resetName + $ resetPict +-- $ resetScope + $ makeExplosionAt (_ptPos (_particles w IM.! ptid)) w + -- $ makeShrapnelBombAt (_ptPos (_particles w IM.! ptid)) w + where resetName = set (creatures . ix n . crInv . ix j . itName) "remoteBomb" + resetPict = set (creatures . ix n . crInv . ix j . itEquipPict ) + (drawWeapon $ remoteBombUnarmedPic) +-- resetScope = creatures . ix n . crInv . ix j . itScope . _Just . scopePos .~ (0,0) + j = _crInvSel $ _creatures w IM.! n +remoteBombPic :: Int -> Picture +remoteBombPic x = pictures [ color (dark $ dark orange) $ circleSolid 5 + , rotate (fromIntegral x * 10 + 45) $ color red $ arc 0 90 5 + , rotate (fromIntegral x * 10 + 45) $ color (withAlpha 0.05 red) + $ arcSolid 0 90 50 + , rotate (fromIntegral x * 10 + 20) $ color (withAlpha 0.05 red) + $ arcSolid 0 40 40 + , rotate (fromIntegral x * 10 + 10) $ color (withAlpha 0.05 red) + $ arcSolid 0 20 20 + ] +remoteBombUnarmedPic :: Picture +remoteBombUnarmedPic = color (dark $ dark orange) $ circleSolid 5 + +drawWeapon :: Picture -> Creature -> Int -> Drawing +drawWeapon p cr posInInv + | _crInvSel cr == posInInv = onLayer PtLayer drawnWep + | otherwise = blank + where drawnWep = uncurry translate (_crRad cr,0) p +--drawWeapon :: Picture -> Creature -> Int -> Maybe (Picture, [Int]) +--drawWeapon p cr posInInv +-- | _crInvSel cr == posInInv = Just (drawnWep, [levLayer PtLayer]) +-- | otherwise = Nothing +-- where drawnWep = uncurry translate (_crRad cr,0) p + +medkit :: Int -> Item +medkit i = basicConsumable + { _itIdentity = Medkit25 + , _itName = "medkit" ++ show i + , _itMaxStack = 9 + , _itAmount = 1 + , _cnEffect = heal i + , _itFloorPict = onLayer FlItLayer $ color blue $ circleSolid 3 + , _itEquipPict = drawWeapon $ color blue $ circleSolid 3 + , _itID = Nothing + } + + +makeTeslaArcAt :: Int -> Point2 -> Float -> Particle +makeTeslaArcAt i pos dir = Particle + { _ptPos = pos + , _ptStartPos = pos + , _ptVel = (0,0) + , _ptPict = onLayer PtLayer $ line [(0,0),(0,0)] + , _ptID = i + , _ptUpdate = moveTeslaArc pos dir i + } + +moveTeslaArc :: Point2 -> Float -> Int -> World -> World +moveTeslaArc p d i w = + set (particles . ix i . ptPict) pic + $ set (particles . ix i . ptUpdate) + (ptTimer 2 i) + $ set randGen g + $ createSpark 8 nc q2 (argV sv + d1) Nothing + $ foldr damCrs w hitCrs + where pic = (onLayer PtLayer $ color (f2 nc) $ line ps') + <> (onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps') + <> (onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps') + <> (onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps') + ps' = lightningMids d pers ps + ps = take 15 $ p : map f (crsLightChain p d 0 w) + f (E3x1 cr) = _crPos cr + f (E3x2 p1) = p1 + f (E3x3 p1) = p1 + pers = evalState (sequence $ repeat $ randInCirc 5) $ _randGen w + (nc,g) = randomR (0::Int,11) $ _randGen w + f1 (E3x1 cr) = Just $ _crID cr + f1 _ = Nothing + hitCrs = mapMaybe f1 $ take 14 $ crsLightChain p d 0 w + damCrs i = over (creatures . ix i . crHP) (\hp -> hp - 5) + f2 0 = cyan + f2 1 = azure + f2 _ = white + sID = newParticleKey w + q1 = last $ init ps' + q2 = last ps' + hitWall = collidePointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w + (d1,_) = randomR (-0.7,0.7) $ _randGen w + sv = fromMaybe (q2 -.- q1) $ fmap snd hitWall + +lightningMid :: Float -> Point2 -> Point2 -> Point2 +lightningMid d p1 p2 = (0.25 *.* (p1 +.+ p2)) +.+ 0.5 *.* p3 + where p3 = errorClosestPointOnLine 1 p1 (p1 +.+ unitVectorAtAngle d) p2 + +lightningMids :: Float -> [Point2] -> [Point2] -> [Point2] +lightningMids d1 (p:pers) (p1:p3:ps) + = let p2 = p +.+ lightningMid d1 p1 p3 + d2 = argV $ p3 -.- p2 + in p1 : p2 : lightningMids d2 pers (p3:ps) +lightningMids _ _ ps = ps + +crsLightChain' :: Point2 -> Float -> World -> [Either3 Creature Point2 Point2] +crsLightChain' p d w + = case crOrWall p d w of + E3x1 cr -> E3x1 cr : crsLightChain' (_crPos cr) (argV (_crPos cr -.- p)) w + E3x2 p1 -> [E3x2 p1] + E3x3 p1 -> E3x3 p1 : crsLightChain' p1 (dChange + argV (p1 -.- p)) (set randGen g w) + -- where (dChange, g) = (0, _randGen w) + where (dChange, g) = randomR (-0.05,0.05) $ _randGen w + +crsLightChain :: Point2 -> Float -> Float -> World -> [Either3 Creature Point2 Point2] +crsLightChain p d wlAttract w + = case crOrWallSensitive p d wlAttract w of + E3x1 cr -> E3x1 cr : crsLightChain (_crPos cr) (argV (_crPos cr -.- p)) + (min 1 (wlAttract + 0.3)) w + E3x2 p1 -> [E3x2 p1] + E3x3 p1 -> E3x3 p1 : crsLightChain p1 (dChange + argV (p1 -.- p)) (min 1 (wlAttract + 0.3)) (set randGen g w) + -- where (dChange, g) = (0, _randGen w) + where (dChange, g) = randomR (-0.05,0.05) $ _randGen w + +crOrWallSensitive :: Point2 -> Float -> Float -> World -> Either3 Creature Point2 Point2 +crOrWallSensitive p dir wlAttract w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0)) + $ listToMaybe $ sortBy (compare `on` g) + $ catMaybes [cr,wlp] + where cr = fmap E3x1 $ nearestCrInFront p dir 100 w + wlp = fmap E3x2 $ listToMaybe + $ sortBy (compare `on` dist p) + $ mapMaybe + ( fmap fst + . (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w) + . (+.+) p + . (\d -> rotateV d (100,0)) + . (+) dir + ) + (fmap (*wlAttract) [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]) + --[-pi/4,-pi/8,0,pi/8,pi/4] + g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first + --g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first + g (E3x1 cr1) = dist p $ _crPos cr1 + (arcLen,_) = randomR (25,50) $ _randGen w +-- BUG: can hit crs through walls + +crOrWall :: Point2 -> Float -> World -> Either3 Creature Point2 Point2 +crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0)) + $ listToMaybe $ sortBy (compare `on` g) + $ catMaybes [cr,wlp] + where cr = fmap E3x1 $ nearestCrInFront p dir 100 w + wlp = fmap E3x2 $ listToMaybe + $ sortBy (compare `on` dist p) + $ mapMaybe + ( fmap fst + . (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w) + . (+.+) p + . (\d -> rotateV d (100,0)) + . (+) dir + ) + [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8] + --[-pi/4,-pi/8,0,pi/8,pi/4] + g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first + --g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first + g (E3x1 cr1) = dist p $ _crPos cr1 + (arcLen,_) = randomR (25,50) $ _randGen w + +-- grapFire :: Int -> World -> World +-- grapFire n w | fireCondition = set (creatures . ix n . crInv . ix itRef . wpFireState) +-- (_wpFireRate (_crInv cr IM.! itRef)) +-- $ over (creatures . ix n . crInv . ix itRef . wpLoadedAmmo) +-- (\x -> x - 1) +-- $ set randGen g +-- $ over particles (IM.insert i (makeGrapFrom i n pos dir)) w +-- | reloadCondition = let remAmmo = _crAmmo cr M.! _wpAmmoType item +-- (newA,newTotalA) = moveInt (_wpMaxAmmo item) remAmmo +-- in set (pointerToItem . wpReloadState) rTime +-- $ set (pointerToItem . wpLoadedAmmo) newA +-- $ over (creatures . ix n . crAmmo ) +-- (M.insert (_wpAmmoType item) newTotalA) w +-- | emptyCondition = soundOnce 1 w +-- | otherwise = w +-- where i = newParticleKey w +-- cr = (_creatures w IM.! n) +-- pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir) +-- dir = _crDir cr -- + a +-- (a,g) = randomR (-0.2,0.2::Float) (_randGen w) +-- itRef = _crInvSel cr +-- item = _crInv cr IM.! itRef +-- pointerToItem = creatures . ix n . crInv . ix itRef +-- rTime = _wpReloadTime (_crInv cr IM.! itRef) +-- fireCondition = _wpReloadState (_crInv cr IM.! itRef) == 0 +-- && _wpFireState (_crInv cr IM.! itRef) == 0 +-- && _wpLoadedAmmo (_crInv cr IM.! itRef) > 0 +-- reloadCondition = _wpReloadState (_crInv cr IM.! itRef) == 0 +-- && _wpLoadedAmmo (_crInv cr IM.! itRef) == 0 +-- && someJust (_crAmmo cr M.!? PistolBullet) +-- emptyCondition = _wpLoadedAmmo (_crInv cr IM.! itRef) == 0 +-- +-- makeGrapFrom :: Int -> Int -> Point -> Float -> Particle +-- makeGrapFrom i ci pos dir = Particle +-- { _ptPos = pos +-- , _ptStartPos = pos +-- , _ptVel = rotateV dir (10,0) +-- , _ptPict = Line [(0,0)] +-- , _ptID = i +-- , _ptUpdate = moveGrap 50 [pos] ci i +-- } +-- +-- moveGrap :: Int -> [Point] -> Int -> Int -> World -> World +-- moveGrap x ls ci i w -- +-- | x < 0 || lineCollide = windGrap' (zipWith (-.-) ls ls5) ci i w +-- | otherwise = case tHit of +-- Just (Left (p,crID)) -> set (particles . ix i . ptUpdate) (windGrap'' i crID ci +-- (_crPos (_creatures w IM.! crID)) +-- sCrP) +-- w +-- Just (Right (p,sv)) -> set (particles . ix i . ptUpdate) +-- (windGrap sCrP (zipWith (-.-) ls ls5 ++[p]) ci i) +-- w +-- _ -> set (particles . ix i . ptUpdate) (moveGrap (x-1) ls1 ci i) +-- $ set (particles . ix i. ptPos) pNewPos +-- $ set (particles . ix i. ptPict) pic +-- w +-- where sCr = _creatures w IM.! ci +-- sCrP = _crPos sCr +-- pic = thickLine ls1 +-- pOldPos = _ptPos (_particles w IM.! i) +-- vel = _ptVel (_particles w IM.! i) +-- ls1 = zipWith (+.+) ls2 $ zipWith f [1,1-step..] ls ++ [pNewPos] +-- step = 1/ (51 - fromIntegral x) +-- f y p = p +.+ (y) *.* crMv +-- pNewPos = pOldPos +.+ vel +-- crMv = sCrP -.- _crOldPos sCr +-- ls3 = (:) (0,0) $ drop x $ take 48 $ cycle $ +-- [lineWidth *.* vNormal vel +-- ,(0,0) +-- ,(-lineWidth) *.* vNormal vel +-- ,(-lineWidth) *.* vNormal vel +-- ,(0,0) +-- ,lineWidth *.* vNormal vel +-- ] +-- lineWidth = 1 +-- lineWidth2 = 0.5 +-- ls2 = ls3 ++ repeat (0,0) +-- ls5 = (:) (0,0) $ drop (x+z) $ take (48+z) $ cycle $ +-- [lineWidth *.* vNormal vel +-- ,(0,0) +-- ,(-lineWidth) *.* vNormal vel +-- ,(-lineWidth) *.* vNormal vel +-- ,(0,0) +-- ,lineWidth *.* vNormal vel +-- ] +-- where z = 2 +-- ls6 = (:) (0,0) $ drop (x+z) $ take (48+z) $ cycle $ +-- [lineWidth2 *.* vNormal vel +-- ,(0,0) +-- ,(-lineWidth2) *.* vNormal vel +-- ,(-lineWidth2) *.* vNormal vel +-- ,(0,0) +-- ,lineWidth2 *.* vNormal vel +-- ] +-- where z = 2 +-- hitCr = collidePointCrsPoint pOldPos pNewPos w +-- hitWl = collidePointWalls pOldPos pNewPos $ wallsNearPoint pNewPos w +-- tHit = thingHit' pOldPos hitCr hitWl +-- lineCollide = foldr (||) False $ zipWith +-- (\a b -> isJust $ collidePointWalls a b +-- $ wallsNearPoint b w) +-- ls (tail ls) + +thingHit' :: Point2 -> Maybe (Point2,a) -> Maybe (Point2,c) -> Maybe (Either (Point2,a) (Point2,c)) +thingHit' p Nothing Nothing = Nothing +thingHit' p (Just x) Nothing = Just (Left x) +thingHit' p Nothing (Just x) = Just (Right x) +thingHit' p (Just x@(p1,_)) (Just y@(p2,_)) + | magV (p -.- p1) > magV (p -.- p2) = Just (Right y) + | otherwise = Just (Left x) + +-- windGrap :: Point -> [Point] -> Int -> Int -> World -> World +-- windGrap cp (x:y:xs) ci i w +-- | dist (_crPos cr) cp < 5 +-- = set (particles . ix i . ptUpdate) (windGrap cNewPos (y:xs) ci i) +-- $ set (particles . ix i . ptPict) (thickLine (y:xs)) +-- $ set (creatures . ix ci . crPos) cNewPos +-- w +-- | otherwise = windGrap' (x:y:xs) ci i w +-- where cr = _creatures w IM.! ci +-- cNewPos = y -.- d +-- d = _crRad cr *.* errorNormalizeV 31 (y -.- x) +-- windGrap _ _ _ i w +-- = over particles (IM.delete i) w +-- +-- windGrap' :: [Point] -> Int -> Int -> World -> World +-- windGrap' (x:[]) _ i w +-- = over particles (IM.delete i) w +-- windGrap' (x:xs) ci i w +-- = set (particles . ix i . ptUpdate) (windGrap' ys ci i) +-- $ set (particles . ix i . ptPict) (thickLine ys) +-- w +-- where ys = init $ zipWith f [1,1-step..] (x:xs) +-- crMv = sCrP -.- _crOldPos sCr +-- sCr = _creatures w IM.! ci +-- sCrP = _crPos sCr +-- f y p = p +.+ (y) *.* crMv +-- step = 1/ (fromIntegral (length xs) + 1) +-- +-- windGrap'' :: Int -> Int -> Int -> Point -> Point -> World -> World +-- windGrap'' pti ci1 ci2 p1 p2 w +-- | dist cp1 cp2 < r1 + r2 + 1 +-- = over particles (IM.delete pti) w +-- | dist cp1 p1 > 5 || dist cp2 p2 > 5 +-- = over particles (IM.delete pti) w +-- | otherwise +-- = set (creatures . ix ci1 . crPos) cpn1 +-- $ set (creatures . ix ci2 . crPos) cpn2 +-- $ set (particles . ix pti . ptPict) (thickLine [ cp1, cp2]) +-- $ set (particles . ix pti . ptUpdate) (windGrap'' pti ci1 ci2 cpn1 cpn2) +-- w +-- where cr1 = _creatures w IM.! ci1 +-- cr2 = _creatures w IM.! ci2 +-- cp1 = _crPos cr1 +-- cp2 = _crPos cr2 +-- r1 = _crRad cr1 +-- r2 = _crRad cr2 +-- m1 = _crMass cr1 +-- m2 = _crMass cr2 +-- v = errorNormalizeV 32 $ cp2 -.- cp1 +-- v1 = 10 * m2 / (m1 + m2) *.* v +-- v2 = (-10 * m1 / (m1 + m2)) *.* v +-- cpn1 = cp1 +.+ v1 +-- cpn2 = cp2 +.+ v2 + +spreadGunSpread,autogunSpread :: Float +spreadGunSpread = 0.5 +autogunSpread = 0.07 + +medkit25,pipe,magShield :: Item +medkit25 = basicConsumable + { _itIdentity = Medkit25 + , _itName = "medkit25" + , _itMaxStack = 3 + , _itAmount = 2 + , _cnEffect = heal25 + , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \cr _ -> blank + } +pipe = Craftable + { _itIdentity = Generic + , _itName = "pipe" + , _itMaxStack = 3 + , _itAmount = 3 + , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \cr _ -> blank + , _itID = Nothing + , _itInvDisplay = _itName + , _itInvColor = green + } +magShield = basicEquipment + { _itIdentity = MagShield + , _itName = "magshield" + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \cr _ -> blank + , _itID = Nothing + } +flameShield = basicEquipment + { _itIdentity = FlameShield + , _itName = "flameShield" + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = (\cr _ -> onLayer CrLayer $ + pictures [color cyan $ circle (_crRad cr+2)] + ) + , _itID = Nothing + } +frontArmour = basicEquipment + { _itIdentity = FrontArmour + , _itName = "frontArmour" + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ translate 0 (-5) $ pictures [color (greyN 0.1) $ thickArc 0 90 10 5 + ,color (greyN 0.1) $ thickArc 270 360 10 5 + ] + , _itEquipPict = (\cr _ -> onLayer CrLayer + $ pictures [color (greyN 0.1) $ thickArc 0 90 (_crRad cr) 5 + ,color (greyN 0.1) $ thickArc 270 360 (_crRad cr) 5 + ] + ) + , _itEffect = NoItEffect + , _itID = Nothing + } +jetPack = basicEquipment + { _itIdentity = JetPack + , _itName = "JetPack" + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = (\cr _ -> onLayer CrLayer + $ pictures [color yellow $ polygon $ rectNSEW 5 (-5) (-3) (-11) + ] + ) + , _itEffect = NoItEffect + , _itID = Nothing + } + +latchkey :: Int -> Item +latchkey n = basicEquipment + { _itIdentity = Generic + , _itName = "key "++show n + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ latchkeyPic + , _itEquipPict = \cr _ -> onLayer PtLayer $ translate (-5) (-5) $ rotate 50 latchkeyPic + , _itEffect = NoItEffect + , _itHammer = HammerUp + , _itID = Nothing + , _itAimingSpeed = 1 + , _itAimingRange = 0 + , _itZoom = basicItZoom + , _itInvColor = yellow + , _itInvDisplay = _itName + } +latchkeyPic = color yellow $ + pictures [translate (-4) 0 $ thickCircle 4 2 + ,lineOfThickness 2 [(0,0),(8,0),(8,-4)] + ,lineOfThickness 2 [(4,0),(4,-4)] + ] + + +-- }}} + +heal25 :: Int -> World -> Maybe World +heal25 n w | _crHP (_creatures w IM.! n) >= 200 = Nothing + | otherwise = Just $ soundOnce healSound + $ over (creatures . ix n . crHP) ((\x-> min x 100). (+ 25) ) w +heal :: Int -> Int -> World -> Maybe World +heal hp n w | _crHP (_creatures w IM.! n) >= 1000 = Nothing + | otherwise = Just $ soundOnce healSound + $ over (creatures . ix n . crHP) ((\x-> min x 1000). (+ hp) ) w + +forceFieldFire :: Int -> World -> World +forceFieldFire cid w = w + +--shatterGunFire :: Int -> World -> World +--shatterGunFire n w | fireCondition = -- soundOnce 0 +-- set (creatures . ix n . crInv . ix itRef . wpFireState) +-- (_wpFireRate (_crInv cr IM.! itRef)) +-- $ over (creatures . ix n . crInv . ix itRef . wpLoadedAmmo) +-- (\x -> x - 1) +-- $ over particles (IM.insert i $ makeTremorAt i pos dir) w +-- | reloadCondition = let remAmmo = _crAmmo cr M.! _wpAmmoType item +-- (newA,newTotalA) = moveInt (_wpMaxAmmo item) remAmmo +-- in set (pointerToItem . wpReloadState) rTime +-- $ set (pointerToItem . wpLoadedAmmo) newA +-- $ over (creatures . ix n . crAmmo ) +-- (M.insert (_wpAmmoType item) newTotalA) w +-- | emptyCondition = soundOnce 1 w +-- | otherwise = w +-- where i = newParticleKey w +-- cr = (_creatures w IM.! n) +-- pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir) +-- dir = _crDir cr +-- --(colID, _) = randomR (0,11) (_randGen w) +-- itRef = _crInvSel cr +-- item = _crInv cr IM.! itRef +-- pointerToItem = creatures . ix n . crInv . ix itRef +-- rTime = _wpReloadTime (_crInv cr IM.! itRef) +-- fireCondition = _wpReloadState (_crInv cr IM.! itRef) == 0 +-- && _wpFireState (_crInv cr IM.! itRef) == 0 +-- && _wpLoadedAmmo (_crInv cr IM.! itRef) > 0 +-- reloadCondition = _wpReloadState (_crInv cr IM.! itRef) == 0 +-- && _wpLoadedAmmo (_crInv cr IM.! itRef) == 0 +-- && someJust (_crAmmo cr M.!? PistolBullet) +-- emptyCondition = _wpLoadedAmmo (_crInv cr IM.! itRef) == 0 + + +--for reloading, we take from the total ammo +moveInt :: Int -> Int -> (Int,Int) +moveInt toReload totalAmmo = (x, totalAmmo-x) + where x = min toReload totalAmmo + +updateTractor :: Int -> Int -> Int -> World -> World +updateTractor colID time i w + | time > 0 = set (particles . ix i . ptUpdate) (updateTractor colID (time-1) i) + $ set (particles . ix i . ptPict) pic + $ over creatures (IM.map tractCr) + $ over floorItems (IM.map tractFlIt) + w + | otherwise = over particles (IM.delete i) w + where tractCr cr | circOnLine p1 p2 cP 10 + = over crPos (\p -> + p -.- m *.* ((0.3/ x) *.* q +.+ (f y *.* p4)) + ) cr + | otherwise = cr + where x = abs y + 1 + y = errorClosestPointOnLineParam 1 p1 p3 cP + cP = _crPos cr + m | dist cP p1 < 350 = 1 + | otherwise = (400 - dist cP p1) / 50 + tractFlIt it | circOnLine p1 p2 iP 10 + = over flItPos (\p -> p -.- m *.* + ( (0.3/ x) *.* q +.+ (f y *.* p4)) + ) it + | otherwise = it + where x = abs y + 1 + y = errorClosestPointOnLineParam 2 p1 p3 iP + iP = _flItPos it + m | dist iP p1 < 350 = 1 + | otherwise = (410 - dist iP p1) / 60 + pt = _particles w IM.! i + q = _ptVel pt + p1 = _ptPos pt + p' = _ptStartPos pt + p2 = fromMaybe p' $ fmap fst $ collidePointWalls p1 p' $ wallsNearPoint p' w + p4 = vNormal p5 + p5 = errorNormalizeV 12 $ p2 -.- p1 + p3 = p1 +.+ p4 + g x | x > 5 = (10 - x) / 5 + | x > 1 = 1 + | x > -1 = x + | x > -5 = -1 + | otherwise = (x - 10) / 5 + d = errorNormalizeV 13 $ p' -.- p1 + f x = g x / 50 + cID = fromIntegral colID / 10 + col = mixColors 0.5 0.5 white blue + px z = (fromIntegral time + 5) *.* z + pz z = fromIntegral time * 10 *.* z + pic = onLayer PtLayer $ color (withAlpha 0.05 col) + $ polygon [ p1 +.+ px p4 + , p1 -.- 10 *.* p5 + , p1 -.- px p4 + , (p' -.- pz p5) -.- px p4 + , (p' -.- pz p5) +.+ px p4] + +thickLine :: [Point2] -> Picture +thickLine = lineOfThickness 2 + +vThickLine :: [Point2] -> Picture +vThickLine = lineOfThickness 3 + +vvThickLine :: [Point2] -> Picture +vvThickLine = lineOfThickness 6 + +thinLine :: [Point2] -> Picture +thinLine = lineOfThickness 1 + +someJust (Just x) | x > 0 = True + | otherwise = False + +shakeCr :: Int -> Float -> World -> World +shakeCr cID amount w = + let vec = vNormal $ unitVectorAtAngle $ _crDir $ _creatures w IM.! cID + (x,g) = randomR (-amount,amount) $ _randGen w + in set randGen g . over (creatures . ix cID . crPos) (+.+ (x *.* vec)) $ w + + +radar = defaultGun + { _itName = "radar" + , _itIdentity = Generic + , _wpMaxAmmo = 100 + , _wpLoadedAmmo = 100 + , _wpAmmoType = PistolBullet + , _wpReloadTime = 200 + , _wpReloadState = 0 + , _wpFireRate = 120 + , _wpFireState = 0 + , _wpFire = shoot $ aRadarPulse + , _wpSpread = autogunSpread + , _wpRange = 20 + , _itHammer = HammerUp + , _itFloorPict = onLayer FlItLayer $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingRange = 1 + , _itZoom = basicItZoom {_itAimZoomMax = 1, _itZoomMax = 1} + , _itEquipPict = drawWeapon $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) + } + +sonar = defaultGun + { _itName = "sonar" + , _itIdentity = Generic + , _wpMaxAmmo = 100 + , _wpLoadedAmmo = 100 + , _wpAmmoType = PistolBullet + , _wpReloadTime = 200 + , _wpReloadState = 0 + , _wpFireRate = 120 + , _wpFireState = 0 + , _wpFire = shoot $ aSonarPulse + , _wpSpread = autogunSpread + , _wpRange = 20 + , _itHammer = HammerUp + , _itFloorPict = onLayer FlItLayer $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) + , _itAmount = 1 + , _itMaxStack = 1 + , _itAimingRange = 1 + , _itZoom = basicItZoom {_itAimZoomMax = 1, _itZoomMax = 1} + , _itEquipPict = drawWeapon $ color blue $ polygon $ rectNESW 5 5 (-5) (-5) + } + +aSonarPulse :: Int -> World -> World +aSonarPulse cid w = over particles' ((:) $ sonarPulseAt (_crPos (_creatures w IM.! cid))) w + +aRadarPulse :: Int -> World -> World +aRadarPulse cid w = over particles' ((:) $ radarPulseAt (_crPos (_creatures w IM.! cid))) w + +blipAt :: Point2 -> Color -> Int -> Particle' +blipAt p col i = Particle' + {_ptPict' = blank + ,_ptUpdate' = mvBlip p col i i + } + +mvBlip :: Point2 -> Color -> Int -> Int -> World -> Particle' -> (World, Maybe Particle') +mvBlip p col maxt 0 w pt = (w, Nothing) +mvBlip p col maxt t w pt + = (w, Just $ pt & ptUpdate' .~ mvBlip p col maxt (t-1) + & ptPict' .~ (onLayerL [levLayer ShadowLayer, 2] + $ uncurry translate p + $ color (withAlpha (fromIntegral t / fromIntegral maxt) col) + $ circleSolid 2) + ) + +sonarPulseAt :: Point2 -> Particle' +sonarPulseAt p = Particle' + { _ptPict' = blank + , _ptUpdate' = mvSonar 100 p + } + +mvSonar :: Int -> Point2 -> World -> Particle' -> (World, Maybe Particle') +mvSonar 0 _ w _ = (w, Nothing) +mvSonar x p w pt = (w, Just $ pt {_ptPict' = pic + ,_ptUpdate' = mvSonar (x-1) p + } + ) + where pic = onLayerL [levLayer ShadowLayer, 2] $ pictures + -- $ sweepPics ++ + crBlips -- ++ wallBlips + crBlips = mapMaybe crBlip $ IM.elems $ _creatures w + crBlip cr | dist cpos p < r + crad && dist cpos p > r - (crad + 100) + = Just $ colHelper (0.5 * (1 - (r - dist cpos p) /100)) + $ uncurry translate cpos $ circleSolid crad + | otherwise = Nothing + where crad = _crRad cr + cpos = _crPos cr + r = fromIntegral (500 - x*5) + sweepPics = [colHelper 0.05 $ uncurry translate p $ thickCircle r 5 +-- ,colHelper 0.3 $ uncurry translate p $ thickCircle (r-5) 5 +-- ,colHelper 0.1 $ uncurry translate p $ thickCircle (r-10) 5 + ] + globalAlpha | x > 10 = 1 + | otherwise = fromIntegral x / 10 + colHelper y = color (withAlpha (y * globalAlpha) green) +-- wallBlips + + +radarPulseAt :: Point2 -> Particle' +radarPulseAt p = Particle' + { _ptPict' = blank + , _ptUpdate' = mvRadar 50 p + } + +mvRadar :: Int -> Point2 -> World -> Particle' -> (World, Maybe Particle') +mvRadar 0 _ w _ = (w, Nothing) +mvRadar x p w pt = (putBlips w, Just $ pt {_ptPict' = pic + ,_ptUpdate' = mvRadar (x-1) p + } + ) + where pic = onLayerL [levLayer ShadowLayer, 1] $ pictures + $ sweepPics + putBlips = over worldEvents ((.) $ over particles' ((++) blips)) + blips = map (\p -> blipAt p (withAlpha (0.5*globalAlpha) red) 50) + $ circPoints + circPoints = mapMaybe (\wl -> collidePointCircCorrect (_wlLine wl !! 0) (_wlLine wl !! 1) r p) + $ (map (over wlLine reverse) $ IM.elems $ wallsAlongCirc p r w) + ++ (IM.elems $ wallsAlongCirc p r w) + r = fromIntegral (800 - x*16) + sweepPics = [--colHelper 0.1 $ uncurry translate p $ thickCircle r 15 + --,colHelper 0.06 $ uncurry translate p $ thickCircle (r-5) 5 + --,colHelper 0.03 $ uncurry translate p $ thickCircle (r-10) 5 + ] + globalAlpha | x > 10 = 1 + | otherwise = fromIntegral x / 10 + colHelper y = color (withAlpha (y * globalAlpha) red) + +autoSonar = basicEquipment + { _itIdentity = Generic + , _itName = "autoSonar" + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \cr _ -> blank + , _itEffect = autoSonarEffect + , _itID = Nothing + , _itAimingSpeed = 1 + , _itAimingRange = 0 + , _itZoom = basicItZoom {_itAimZoomMax = 1, _itZoomMax = 1} + } +autoRadar = basicEquipment + { _itIdentity = Generic + , _itName = "autoRadar" + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \cr _ -> blank + , _itEffect = autoRadarEffect + , _itID = Nothing + , _itAimingSpeed = 1 + , _itAimingRange = 0 + , _itZoom = basicItZoom {_itAimZoomMax = 1, _itZoomMax = 1} + } + +autoRadarEffect :: ItEffect +autoRadarEffect = ItInvEffect {_itInvEffect = f 50 + ,_itEffectCounter = 0 + } + where f 0 cr i w = aRadarPulse (_crID cr) + w & creatures . ix (_crID cr) . crInv . ix i + . itEffect . itInvEffect .~ f 100 + f t cr i w = w & creatures . ix (_crID cr) . crInv . ix i + . itEffect . itInvEffect .~ f (t-1) + +autoSonarEffect :: ItEffect +autoSonarEffect = ItInvEffect {_itInvEffect = f 50 + ,_itEffectCounter = 0 + } + where f 0 cr i w = aSonarPulse (_crID cr) + w & creatures . ix (_crID cr) . crInv . ix i + . itEffect . itInvEffect .~ f 40 + f t cr i w = w & creatures . ix (_crID cr) . crInv . ix i + . itEffect . itInvEffect .~ f (t-1) + +itemLaserScopeEffect :: ItEffect +itemLaserScopeEffect + = ItInvEffect {_itInvEffect = f + ,_itEffectCounter = 0 + } + where f cr invid w + | invid == _crInvSel cr + = w & particles' %~ (:) (makeLaserScope sp ep d reloadFrac) + & creatures . ix (_crID cr) . crInv . ix invid . itHammer %~ moveHammerUp + & flareWidth 2 1 15 32 col 0.05 0.1 (ep -.- 4 *.* unitVectorAtAngle d) +-- this flare MAY be buggy... something to do with the creature glare + | otherwise = w + where + p = _crPos cr + d = _crDir cr + r = _crRad cr + sp = (p +.+ (r + 3) *.* unitVectorAtAngle d) + xp = sp +.+ 3000 *.* unitVectorAtAngle d + ep = case listToMaybe $ thingsHitLongLine sp xp w of + Just (p,_) -> p + Nothing -> xp + it = (cr ^. crInv) IM.! invid + reloadFrac + | _wpLoadedAmmo it == 0 = 1 + | otherwise = fromIntegral (_wpReloadState it) / fromIntegral (_wpReloadTime it) + col = mixColors reloadFrac (1-reloadFrac) red green + moveHammerUp !HammerDown = HammerReleased + moveHammerUp !_ = HammerUp + +makeLaserScope :: Point2 -> Point2 -> Float -> Float -> Particle' +makeLaserScope p ep d relFrac = Particle' + {_ptPict' = onLayer PtLayer $ pictures + [color (withAlpha 0.5 $ mixColors relFrac (1-relFrac) red green) + $ lineOfThickness 0.5 [p,ep] + ,color (withAlpha 0.2 $ mixColors relFrac (1-relFrac) red green) + $ lineOfThickness 1.5 [p,ep] + ,color (withAlpha 0.1 $ mixColors relFrac (1-relFrac) red green) + $ lineOfThickness 2 [p,ep] + ] + ,_ptUpdate' = \w pt -> (w, Just $ pt & ptUpdate' .~ \w' _ -> (w',Nothing)) + } diff --git a/src/Dodge/WorldActions.hs b/src/Dodge/WorldActions.hs new file mode 100644 index 000000000..17907fe8d --- /dev/null +++ b/src/Dodge/WorldActions.hs @@ -0,0 +1,901 @@ +module Dodge.WorldActions where + +import Dodge.Data +import Dodge.Base +import Dodge.SoundLogic +import Dodge.RandomHelp +import Geometry +import Picture + +import Control.Lens +import Control.Monad.State + +import System.Random + +import Data.Maybe +import Data.Function +import Data.List +import qualified Data.IntMap.Strict as IM + +makeExplosionAt :: Point2 -> World -> World +makeExplosionAt p w = soundOnce grenadeBang + $ over tempLightSources ((:) $ tLightFade 20 150 intensityF p) + $ fs + $ over particles (IM.insert n exp) + w + where n = newParticleKey w + exp = Particle + { _ptPos = p + , _ptStartPos = p + , _ptVel = (0,0) + , _ptPict = blank + , _ptID = n + , _ptUpdate = explosionWaveDamage 6 p n + } + fVs = fst $ runState ((sequence . take 75 . repeat . randInCirc) 1) $ _randGen w + fPs' = evalState ((sequence . take 75 . repeat . randInCirc) 15) $ _randGen w + fPs = map (pushAgainstWalls . (+.+) p . (*.*) 0.5) + --fPs = map (pushAgainstWalls . (+.+) p . (*.*) 5) + fPs' + inversePushOut v = (15 - magV v) * 0.01 *.* v + fVs' = zipWith (+.+) fVs $ map inversePushOut fPs' + sizes = randomRs (2,6) $ _randGen w + times = randomRs (20,25) $ _randGen w + mF q v size time = makeFlameletTimed q v (levLayer GloomLayer - 1) Nothing size time + newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times + fs w = foldr ($) w newFs + pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y) + $ collidePointWalls p q $ wallsNearPoint q w + fadeFac x | x > 10 = 0 + | otherwise = 1 - fromIntegral x / 10 + intensityF x | x < 10 = 1 / (10 - fromIntegral x) + | otherwise = 1 + +explosionWaveDamage :: Int -> Point2 -> Int -> World -> World +explosionWaveDamage 0 p ptid = over particles (IM.delete ptid) +explosionWaveDamage time p ptid + = set (particles . ix ptid . ptUpdate) (explosionWaveDamage (time-1) p ptid) + . shockWaveDamage p rad 20 + . set (particles . ix ptid . ptPict) shockwavePic + . lowLightRadAt white 0.3 75 150 p + where shockwavePic = onLayer PtLayer $ uncurry translate p $ color (withAlpha 0.9 white) + $ thickCircle rad (thickness*2) + thickness = max 0 $ sqrt $ (fromIntegral time - 2) * 8 + rad = 40 - thickness + +shockWaveDamage :: Point2 -> Float -> Int -> World -> World +shockWaveDamage p rad amount w = flip (foldr damageBlocks) hitBlocks $ over creatures (IM.map f) w + where f cr | dist (_crPos cr) p < rad + _crRad cr = over (crState . crDamage) + ((:) $ Concussive amount p 2 0.5 rad) cr + | otherwise = cr + hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - (div amount 2))) + w + (_blIDs wall) + _ -> w + +makeShockwaveAt :: Point2 -> Float -> Int -> Float -> Color + -> World -> World +makeShockwaveAt p rad dam push col = over particles' ((:) theShockwave) + where theShockwave = shockwaveAt p rad dam push col 10 + +shockwaveAt :: Point2 -> Float -> Int -> Float -> Color -> Int -> Particle' +shockwaveAt p rad dam push col maxtime + = Shockwave' + { _ptPict' = blank + , _ptUpdate' = mvShockwave' + , _btColor' = col + , _btPos' = p + , _btRad' = rad + , _btDam' = dam + , _btPush' = push + , _btMaxTime' = maxtime + , _btTimer' = maxtime + } + +mvShockwave' :: World -> Particle' -> (World, Maybe Particle') +mvShockwave' w pt + | _btTimer' pt <= 0 = (w, Nothing) + | otherwise + = (dams w , Just $ set btTimer' (t - 1) $ set ptPict' pic pt) + where r = _btRad' pt + p = _btPos' pt + push = _btPush' pt + dam = _btDam' pt + t = _btTimer' pt + tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt) + pic = onLayer PtLayer $ uncurry translate p + $ color (_btColor' pt) $ thickCircle rad thickness + rad = r - (3/4) * r * tFraction + thickness = tFraction**2 * r + dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks + hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) + w + (_blIDs wall) + _ -> w + damCr cr | dist (_crPos cr) p < rad + _crRad cr + = over (crState . crDamage) + ((:) $ PushDam dam (25 * push *.* safeNormalizeV (_crPos cr -.- p))) + cr + | otherwise = cr +moveShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle') +moveShockWave 0 _ _ _ _ w _ = (w, Nothing) +moveShockWave t p r push pushexp w pt + = (dams w, Just $ newupdate $ newpic pt ) + where newupdate = set ptUpdate' $ moveShockWave (t-1) p r push pushexp + newpic = set ptPict' (onLayer PtLayer $ uncurry translate p + $ color cyan $ thickCircle rad thickness) + rad = r - (3/40) * r * fromIntegral t + thickness = (fromIntegral t)**2 * rad / 40 + dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks + hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) + w + (_blIDs wall) + _ -> w + damCr cr | dist (_crPos cr) p < rad + _crRad cr + = over (crState . crDamage) + ((:) $ PushDam 1 (25 *.* safeNormalizeV (_crPos cr -.- p))) + cr + | otherwise = cr + +inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World +inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave) + where theShockwave + = Particle' + { _ptPict' = blank + , _ptUpdate' = moveInverseShockWave 10 p rad push pushexp + } +moveInverseShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle') +moveInverseShockWave 0 _ _ _ _ w _ = (w, Nothing) +moveInverseShockWave t p r push pushexp w pt + = (dams w, Just $ newupdate $ newpic pt ) + where newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp + newpic = set ptPict' (onLayer PtLayer $ uncurry translate p + $ color cyan $ thickCircle rad thickness) + rad = r - (4/40) * r * fromIntegral (10 - t) + thickness = (fromIntegral (10 - t))**2 * rad / 40 + dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks + hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) + w + (_blIDs wall) + _ -> w + damCr cr | dist (_crPos cr) p < rad + _crRad cr + = over (crState . crDamage) + ((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr))) + cr + | otherwise = cr + + +-- makeTremorAt :: Int -> Point -> Float -> Particle +-- makeTremorAt i pos d = Particle +-- { _ptPos = (0,0) +-- , _ptStartPos = (0,0) +-- , _ptVel = (0,0) +-- , _ptPict = Line [(0,0),(0,0)] +-- , _ptID = i +-- , _ptUpdate = moveTremor [pos] 200 pos d i +-- } +-- +-- moveTremor :: [Point] -> Int -> Point -> Float -> Int -> World -> World +-- moveTremor ps t p1 d i w +-- | t <= -30 = over particles (IM.delete i) . over partUnder (IM.delete i) $ w +-- | t <= 0 = set (particles . ix i . ptUpdate) (moveTremor ps (t-1) p1 d i) +-- . over partUnder +-- (IM.insert i (lineOfThickness (0.1*(fromIntegral t + 30)) ps)) $ w +-- | otherwise = case hitWall of +-- Nothing -> upUndPict . set randGen g . shakeCrs . +-- shatterAt p1 pl $ shatterAt p1 pr +-- $ set (particles . ix i . ptUpdate) (moveTremor (p3:ps) (t-1) p3 d i) +-- $ damCrsOnLine 10 p1 p3 w +-- Just (pw,pRef) -> set (particles . ix i . ptUpdate) (moveTremor ps (t-1) p1 (argV pRef) i) w +-- where p2 = p1 +.+ 5 *.* unitVectorAtAngle d +-- pl = p1 +.+ rotateV (d + pi/4) (75,0) +-- pr = p1 +.+ rotateV (d - pi/4) (75,0) +-- hitWall = collidePointWalls p1 p3 $ wallsAlongLine p1 p3 w +-- (d1,g) = randomR (0,2*pi) $ _randGen w +-- v = unitVectorAtAngle d1 +-- p3 = p2 +.+ 5 *.* v +-- shakeCrs = over creatures (IM.map shCr) +-- shCr cr | dist p1 (_crPos cr) < 75 = over crPos (+.+ v) cr +-- | otherwise = cr +-- upUndPict = over partUnder (IM.insert i pic) +-- pic = pictures [color white $ lineOfThickness 3 [p3,head ps] +-- ,lineOfThickness 3 ps] +-- +-- makeTremorAt' :: Int -> Point -> Particle +-- makeTremorAt' i pos = Particle +-- { _ptPos = (0,0) +-- , _ptStartPos = (0,0) +-- , _ptVel = (0,0) +-- , _ptPict = Line [(0,0),(0,0)] +-- , _ptID = i +-- , _ptUpdate = rotateTremorAround 10 pos i +-- } +-- +-- rotateTremorAround :: Int -> Point -> Int -> World -> World +-- rotateTremorAround 0 p i w = over particles (IM.delete i) w +-- rotateTremorAround t p i w = set (particles . ix i . ptUpdate) (rotateTremorAround (t-1) p i) +-- $ foldr ($) w shatters +-- where rot d = rotateV $ d + fromIntegral t * pi / 7 +-- ds = fmap (\x -> fromIntegral x * pi / 2.5) [0..4] +-- shatters = map (\d -> shatterAt p (p +.+ rot d (300,0))) ds +-- +-- shatterAt :: Point -> Point -> World -> World +-- shatterAt p1 p2 w = case wlHit of +-- Just (p,v,col) -> makeFallingBlock col (f1 p) (f2 v) +-- $ set randGen g w +-- _ -> w +-- where wlHit = collidePointWallsNormCol p1 p2 $ wallsNearPoint p2 w +-- f1 q = q +.+ 5 *.* errorNormalizeV 10 (p2 -.- p1) +-- (d,g) = randomR (-0.5,0.5) $ _randGen w +-- f2 v' = rotateV d $ 3 *.* errorNormalizeV 11 v' +-- +-- fallingWall :: Int -> Color -> Point -> Float -> Particle +-- fallingWall pid col p d +-- = Particle +-- { _ptPos = p +-- , _ptStartPos = p +-- , _ptVel = rotateV d (3,0) +-- , _ptPict = Line [(0,0),(0,0)] +-- , _ptID = pid +-- , _ptUpdate = moveFallingWall 10 p d col pid +-- } +-- +-- moveFallingWall :: Int -> Point -> Float -> Color -> Int -> World -> World +-- moveFallingWall 0 p d col i w = over particles (IM.delete i) $ b1 $ b2 w +-- where b1 = makeFallingBlock col (p +.+ ( 3, 3)) (rotateV d (0,5)) +-- b2 = makeFallingBlock col (p +.+ (-3,-3)) (rotateV d (0,1)) +-- moveFallingWall t p d col i w +-- = set (particles . ix i . ptUpdate) (moveFallingWall (t-1) np d col i) +-- $ set (particles . ix i . ptPict) pic +-- w +-- where np = p +.+ 1 *.* unitVectorAtAngle d +-- pic = uncurry translate p $ rotate (-radToDeg d) +-- $ color col $ polygon [(-6,-6) +-- ,(-6, 6) +-- ,( 6, 6) +-- ,( 6,-6) +-- ] +-- +-- makeFallingBlock :: Color -> Point -> Point -> World -> World +-- makeFallingBlock col p v w +-- = over particles (IM.insert i $ fallingBlock i col p v) w +-- where i = newParticleKey w +-- +-- fallingBlock :: Int -> Color -> Point -> Point -> Particle +-- fallingBlock pid col p v +-- = Particle +-- { _ptPos = p +-- , _ptStartPos = p +-- , _ptVel = v +-- , _ptPict = Line [(0,0),(0,0)] +-- , _ptID = pid +-- , _ptUpdate = moveFallingBlock 10 p v col pid +-- } +-- +-- moveFallingBlock :: Int -> Point -> Point -> Color -> Int -> World -> World +-- moveFallingBlock 0 p v col i w = over particles (IM.delete i) w +-- moveFallingBlock t p v col i w +-- = case hitCr of +-- Nothing -> set (particles . ix i . ptUpdate) (moveFallingBlock (t-1) np v col i) +-- $ set (particles . ix i . ptPict) pic +-- w +-- Just (p1,v1,crID) -> over particles (IM.delete i) +-- $ over (creatures . ix crID . crHP) (\hp -> hp - 1) w +-- where np = p +.+ v +-- pic = uncurry translate p $ rotate (-radToDeg (argV v)) +-- $ color col $ polygon [(-3,-3) +-- ,(-3, 3) +-- ,( 3, 3) +-- ,( 3,-3) +-- ] +-- hitCr = reflectCircCreatures 4 p np $ _creatures w + + +-- if the spark is created by another Particle', it cannot be directly added to +-- the list, hence the redirect through worldEvents +createSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World +createSpark time colid pos dir maycid w = over worldEvents + ((.) $ ( over particles' ((:) spark) + . flareAt' white 0.02 0.05 pos') + -- . lowLightAt' pos) + ) w + where spark = Bul' { _ptPict' = blank + , _ptUpdate' = mvGenBullet' + , _btVel' = rotateV dir (5,0) + , _btColor' = numColor colid + , _btTrail' = [pos] + , _btPassThrough' = maycid + , _btWidth' = 1 + , _btTimer' = time + , _btHitEffect' = threeEff' sparkEff noEff noEff + } + x = fst $ randomR (0,20) $ _randGen w + pos' = pos +.+ rotateV dir (x,0) + sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage) + ((:) $ SparkDam 1 sp p ep) + where sp = head (_btTrail' bt) + ep = sp +.+ _btVel' bt + +createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World +createBarrelSpark time colid pos dir maycid w = over worldEvents + ((.) $ ( over particles' ((:) spark) + . flareAt' white 0.005 0.03 pos') + -- . lowLightAt' pos) + ) w + where spark = Bul' { _ptPict' = blank + , _ptUpdate' = mvGenBullet' + , _btVel' = rotateV dir (5,0) + , _btColor' = numColor colid + , _btTrail' = [pos] + , _btPassThrough' = maycid + , _btWidth' = 1 + , _btTimer' = time + , _btHitEffect' = threeEff' sparkEff noEff noEff + } + x = fst $ randomR (0,20) $ _randGen w + pos' = pos +.+ rotateV dir (x,0) + sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage) + ((:) $ SparkDam 1 sp p ep) + where sp = head (_btTrail' bt) + ep = sp +.+ _btVel' bt + +flareAt :: Color -> Point2 -> World -> World +flareAt c p = flareAt' c 0.02 0.5 p + +flareAt' :: Color -> Float -> Float -> Point2 -> World -> World +flareAt' col alphax alphay p + = over particles' ((:) (flashColAt col alphax p)) + . lowLightColAt col alphay p + + +tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource +tLightFade 0 rmax intensityF p = + TLS { _tlsPos = p + , _tlsRad = rmax + , _tlsIntensity = intensityF 0 + , _tlsUpdate = \w _ -> (w, Nothing) + } +tLightFade i rmax intensityF p = + TLS { _tlsPos = p + , _tlsRad = rmax + , _tlsIntensity = intensityF i + , _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p) + } + +tLightRad :: Int -> Float -> Float -> Point2 -> TempLightSource +tLightRad 0 rmax rmin p = + TLS { _tlsPos = p + , _tlsRad = rmax + , _tlsIntensity = 0.5 + , _tlsUpdate = \w _ -> (w, Nothing) + } +tLightRad i rmax rmin p = + TLS { _tlsPos = p + , _tlsRad = rmax + , _tlsIntensity = 0.5 + , _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p) + } + +tLightAt i p = tLightRad i 100 0 p + +flareWidth :: Float -> Float -> Float -> Int -> Color -> Float -> Float -> Point2 -> World -> World +flareWidth len wdth rad rays col ax ay p + = over particles' ((:) (flashRadAt rad col ax p)) + . lowLightWidthAt len wdth col ay rays rad p + +flareRad :: Float -> Int -> Color -> Float -> Float -> Point2 -> World -> World +flareRad rad rays col ax ay p + = over particles' ((:) (flashRadAt rad col ax p)) + . lowLightRadAt col ay rays rad p + +flashRadAt :: Float -> Color -> Float -> Point2 -> Particle' +flashRadAt rad col alphax (x,y) = + Particle' + { _ptPict' = mconcat $ + map (\i -> onLayerL [levLayer PtLayer] + $ color (withAlpha alphax col) $ translate x y $ circleSolid i + ) + [rad/5,2*rad/5,3*rad/5,4*rad/5,rad] + , _ptUpdate' = ptTimer' 1 + } + +flashColAt :: Color -> Float -> Point2 -> Particle' +flashColAt col alphax (x,y) = + Particle' + { _ptPict' = mconcat $ + map (\i -> onLayerL [levLayer PtLayer] + $ color (withAlpha alphax col) $ translate x y $ circleSolid i + ) + [20,25,30,35,40,45,50] + , _ptUpdate' = ptTimer' 1 + } +lowLightWidthAt :: Float -> Float -> Color -> Float -> Int -> Float -> Point2 -> World -> World +lowLightWidthAt len wdth col alphay rays rad p w = foldr (lowLightWidthHit len wdth col alphay p) w ps + where ps = map ((+.+) p) $ nRaysRad rays rad + +lowLightRadAt :: Color -> Float -> Int -> Float -> Point2 -> World -> World +lowLightRadAt col alphay rays rad p w = foldr (lowLightColHit col alphay p) w ps + where ps = map ((+.+) p) $ nRaysRad rays rad + +lowLightColAt :: Color -> Float -> Point2 -> World -> World +lowLightColAt col alphay p w = foldr (lowLightColHit col alphay p) w ps + where ps = map ((+.+) p) $ nRaysRad 20 30 + +lowLightDirected :: Color -> Float -> Point2 -> Point2 -> [Float] -> World -> World +lowLightDirected col alpha a b angles w + = foldr (\angle w' -> lowLightColHit col alpha a (a +.+ rotateV angle b) w') w angles + +lowLightColHit :: Color -> Float -> Point2 -> Point2 -> World -> World +lowLightColHit col alphay a b w + = case thingsHitLongLine a b w of + ((p, E3x2 wall):_) + -> over particles' ((:) (wallGlareCol col alphay p wall)) w + ((p, E3x1 cr):_) + -> over afterParticles' ((:) (crGlareCol col alphay p cr)) w + _ -> w + +wallGlareCol :: Color -> Float -> Point2 -> Wall -> Particle' +wallGlareCol col alphay p wl = wallGlareWidth 10 5 col alphay p wl + +crGlareCol :: Color -> Float -> Point2 -> Creature -> Particle' +crGlareCol col alphay p cr = crGlareWidth 5 col alphay p cr + +lowLightWidthHit :: Float -> Float -> Color -> Float -> Point2 -> Point2 -> World -> World +lowLightWidthHit len wdth col alphay a b w + = case thingsHitLongLine a b w of + ((p, E3x2 wall):_) + -> over particles' ((:) (wallGlareWidth len wdth col alphay p wall)) w + ((p, E3x1 cr):_) + -> over afterParticles' ((:) (crGlareWidth wdth col alphay p cr)) w + _ -> w + +wallGlareWidth :: Float -> Float -> Color -> Float -> Point2 -> Wall -> Particle' +wallGlareWidth len wdth col alphay p wl = + Particle' + { _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l + , _ptUpdate' = ptTimer' 1 + } + where l = color (withAlpha alphay col) $ lineOfThickness wdth $ [p +.+ x, p -.- x] + x = len *.* ( normalizeV $ a -.- b) + (a:b:_) = _wlLine wl + +crGlareWidth :: Float -> Color -> Float -> Point2 -> Creature -> Particle' +crGlareWidth wdth col alphay p cr = + Particle' + { _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l cp + --{ _ptPict' = [(blank, [levLayer WlLayer + 2])] + , _ptUpdate' = \w pt -> (w, Just $ pt {_ptPict' = onLayerL [levLayer GloomLayer + 2] $ upp cid w + ,_ptUpdate' = ptTimer' 0 + } + ) + } + where l x = uncurry translate x + $ rotate (90 - (radToDeg $ argV (p -.- x))) + $ color (withAlpha alphay col) + $ thickArc 0 180 (_crRad cr) wdth +-- where l = rotate (radToDeg $ argV (cp -.- p)) $ uncurry translate cp $ color (withAlpha 0.5 white) $ thickArc 0 25 (_crRad cr) 5 + cp = _crPos cr + cid = _crID cr + upp cid' w' = case w' ^? creatures . ix cid . crPos of + Just y -> l y + --Just p -> uncurry translate p $ circleSolid 5 + _ -> blank + +muzFlareAt :: Point2 -> World -> World +muzFlareAt p = over particles' ((:) (muzzleFlareAt p)) + . lowLightAt p + +muzzleFlareAt :: Point2 -> Particle' +muzzleFlareAt (x,y) = + Particle' + { _ptPict' = mconcat + $ map (\i -> onLayer PtLayer $ color (withAlpha 0.02 white) $ translate x y $ circleSolid i + ) + [20,25,30,35,40,45,50] + , _ptUpdate' = ptTimer' 1 + } + +ptTimer' :: Int -> World -> Particle' -> (World, Maybe Particle') +ptTimer' 0 w pt = (w, Nothing) +ptTimer' n w pt = (w, Just $ pt {_ptUpdate' = ptTimer' (n-1)}) + +lowLightAt :: Point2 -> World -> World +lowLightAt p w = lowLightWidthAt 10 5 white 0.5 20 30 p w + +lowLightHit :: Point2 -> Point2 -> World -> World +lowLightHit a b w + = case thingsHitLongLine a b w of + ((p, E3x2 wall):_) + -> over particles' ((:) (wallGlare p wall)) w + ((p, E3x1 cr):_) + -> over afterParticles' ((:) (crGlare p cr)) w + _ -> w + +wallGlare :: Point2 -> Wall -> Particle' +wallGlare p wl = wallGlareWidth 10 5 white 0.5 p wl + +crGlare :: Point2 -> Creature -> Particle' +crGlare = crGlareCol white 0.5 +-- crGlare p cr = +-- Particle' +-- { _ptPict' = [(l, [levLayer WlLayer + 2])] +-- , _ptUpdate' = ptTimer' 1 +-- } +-- where l = uncurry translate cp +-- $ rotate (90 - (radToDeg $ argV (p -.- cp))) +-- $ color (withAlpha 0.5 white) +-- $ thickArc 0 180 (_crRad cr) 5 +-- -- where l = rotate (radToDeg $ argV (cp -.- p)) $ uncurry translate cp $ color (withAlpha 0.5 white) $ thickArc 0 25 (_crRad cr) 5 +-- cp = _crPos cr + + +lowLightAt' :: Point2 -> World -> World +lowLightAt' p w = foldr (lowLightHit' p) w ps + where ps = map ((+.+) p) $ nRaysRad 20 30 + +lowLightHit' :: Point2 -> Point2 -> World -> World +lowLightHit' a b w + = case thingsHitLongLine a b w of + ((p, E3x2 wall):_) + -> over particles' ((:) (wallGlare' p wall)) w + _ -> w + +wallGlare' :: Point2 -> Wall -> Particle' +wallGlare' p wl = wallGlareWidth 5 5 white 0.1 p wl + +noEff _ _ _ = id + +threeEff' :: + ( Particle' -> Point2 -> Creature -> World -> World ) -> + ( Particle' -> Point2 -> Wall -> World -> World ) -> + ( Particle' -> Point2 -> ForceField -> World -> World ) -> + Particle' -> (Point2, Either3 Creature Wall ForceField) -> World -> World +threeEff' crEff wlEff ffEff pt thing w = case thing of + (p,E3x1 cr) -> crEff pt p cr w + (p,E3x2 wl) -> wlEff pt p wl w + (p,E3x3 ff) -> ffEff pt p ff w + +mvGenBullet' :: World -> Particle' -> (World, Maybe Particle') +mvGenBullet' w bt + | t <= 0 = (w, Nothing) + | t < 4 = (w, Just $ set btPassThrough' Nothing + $ set btTrail' (p:p:ps) + $ set ptPict' (bulLine col wth (p:p:ps)) + $ set btTimer' (t-1) bt + ) + | otherwise = case thingsHitExceptCr mcr p (p +.+ vel) w of + [] -> (w, Just $ set btPassThrough' Nothing + $ set btTrail' (p +.+ vel :p:ps) + $ set ptPict' (bulLine col wth (p +.+ vel:p:ps)) + $ set btTimer' (t-1) bt + ) + ((hitp,thing):_) + -> ( hiteff bt (hitp,thing) w + , Just $ set btPassThrough' Nothing + $ set btTrail' (hitp:p:ps) + $ set ptPict' (bulLine col wth (hitp:p:ps)) + $ set btTimer' 3 bt + ) + where mcr = _btPassThrough' bt + col = _btColor' bt + (p:ps) = _btTrail' bt + vel = _btVel' bt + hiteff = _btHitEffect' bt + wth = _btWidth' bt + t = _btTimer' bt + +bulLine :: Color -> Float -> [Point2] -> Drawing +bulLine col width (a:b:[]) + = onLayer HPtLayer $ pictures + [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,b] + ,color white $ wedgeOfThickness width a b +-- ,color white $ lineOfThickness width [a,b] +-- ,color (withAlpha 0.3 white) $ lineOfThickness width [a3,b] +-- ,color (withAlpha 0.7 white) $ lineOfThickness width [a2,a3] + ] +-- where a2 = (0.7 *.* a) +.+ (0.3 *.* b) +-- a3 = (0.3 *.* a) +.+ (0.7 *.* b) +bulLine col width (a:b:c:_) + = onLayer HPtLayer $ pictures + [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,c] + ,color white $ wedgeOfThickness width a c +-- ,color white $ lineOfThickness width [a,b] +-- ,color (withAlpha 0.3 white) $ lineOfThickness (width-1) [a3,c] +-- ,color (withAlpha 0.7 white) $ lineOfThickness width [a2,a3] +-- ,color white $ lineOfThickness width [a,a2] + ] +-- where a2 = b +-- a3 = (0.5 *.* b) +.+ (0.5 *.* c) +-- where a2 = (0.7 *.* a) +.+ (0.3 *.* b) +-- a3 = (0.3 *.* a) +.+ (0.7 *.* b) +--bulLine col width (a:b:c:d:_) +-- = onLayer HPtLayer $ pictures +-- [color (withAlpha 0.5 col) $ lineOfThickness (width+1) [a,c] +-- ,color (withAlpha 0.3 white) $ lineOfThickness width [a3,b] +-- ,color (withAlpha 0.7 white) $ lineOfThickness width [a2,a3] +-- ,color white $ lineOfThickness width [a,a2] +-- ] +-- where a2 = (0.7 *.* a) +.+ (0.3 *.* b) +-- a3 = (0.3 *.* a) +.+ (0.7 *.* b) + +thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World + -> [(Point2, (Either3 Creature Wall ForceField))] +thingsHitExceptCr Nothing sp ep = thingsHit sp ep +thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep + where crNotCid (_,(E3x1 cr)) = _crID cr /= cid + crNotCid _ = True + +thingsHit :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))] +thingsHit sp ep w = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs) + where hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr)) + $ creaturesAlongLine sp ep w + crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs + crs = zip crPs (map E3x1 hitCrs) + -- hitWls = wallsOnLine sp ep (f y $ f x $ _wallsZone w) + hitWls = wallsOnLine sp ep (IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] + , b<-[y-1,y,y+1]]) + (x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep)) + f i m = case IM.lookup i m of Just val -> val + _ -> IM.empty + walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) + hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1) + hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w) + ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs + +thingsHitExceptCrLongLine :: Maybe Int -> Point2 -> Point2 -> World + -> [(Point2, (Either3 Creature Wall ForceField))] +thingsHitExceptCrLongLine Nothing sp ep = thingsHitLongLine sp ep +thingsHitExceptCrLongLine (Just cid) sp ep = filter crNotCid . thingsHitLongLine sp ep + where crNotCid (_,(E3x1 cr)) = _crID cr /= cid + crNotCid _ = True + +thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))] +--thingsHitLongLine sp ep w = crs ++ walls +thingsHitLongLine sp ep w = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs) + where hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr)) + -- $ _creatures w + $ creaturesAlongLine sp ep w + crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs + --crPs = map _crPos hitCrs + crs = zip crPs (map E3x1 hitCrs) + -- hitWls = wallsOnLine sp ep (f y $ f x $ _wallsZone w) + hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w + --hitWls = wallsOnLine sp ep $ _walls w + f i m = case IM.lookup i m of Just val -> val + _ -> IM.empty + --walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) + walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) + hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1) +-- hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1) + hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w) + ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs + cr = _creatures w IM.! 0 + +makeFlameletTimed :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> Int -> World -> World +makeFlameletTimed pos vel levelInt maycid size time w + = set randGen g $ over particles' ((:) theFlamelet) + $ flareAt' white 0.01 0.1 pos w + where theFlamelet = + Pt' { _ptPict' = blank + , _ptUpdate' = moveFlamelet levelInt rot + , _btVel' = vel + , _btColor' = red + , _btPos' = pos + , _btPassThrough' = maycid + , _btWidth' = size + , _btTimer' = time + , _btHitEffect' = threeEff' (doFlameDam 1) noEff noEff + } + (rot ,g) = randomR (0,3) $ _randGen w + +makeFlamelet :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> World -> World +makeFlamelet pos vel levelInt maycid size w = set randGen g $ over particles' ((:) theFlamelet) w + where theFlamelet = + Pt' { _ptPict' = blank + , _ptUpdate' = moveFlamelet levelInt rot + , _btVel' = vel + , _btColor' = red + , _btPos' = pos + , _btPassThrough' = maycid + , _btWidth' = size + , _btTimer' = 20 + , _btHitEffect' = threeEff' (doFlameDam 1) noEff noEff + } + (rot ,g) = randomR (0.5,1.5) $ _randGen w +moveFlamelet :: Int -> Float -> World -> Particle' -> (World, Maybe Particle') +moveFlamelet levelInt rot w pt = + case _btTimer' pt of + time | time <= 0 -> (w, Nothing) + | otherwise -> (damcrs, mvPt) + where sp = _btPos' pt + vel = _btVel' pt + ep = sp +.+ vel + size = _btWidth' pt + siz2 = size + 0.2 + mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep, _ptPict' = thepicture + , _btPassThrough' = Nothing + ,_btVel' = 0.8 *.* vel} + damcrs = foldr ($) w $ map dodam $ filter closeCrs $ IM.elems $ _creatures w + closeCrs cr = dist ep (_crPos cr) < _crRad cr + size + dodam cr = over (creatures . ix (_crID cr) . crState . crDamage) + ((:) $ Flaming 3 sp ep ep) + pic = onLayerL [levelInt,3] $ uncurry translate ep + $ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) + white (dark red) + ) + $ rotate (radToDeg ( 0.1 * fromIntegral time + rot)) + $ scale sc sc + $ polygon [(-size,-size),(size,-size),(size,size),(-size,size)] + piu = onLayerL [levelInt,1] $ uncurry translate ep + $ color (dark red) $ rotate (radToDeg (rot - 0.1 * fromIntegral time)) + $ scale s1 s1 + $ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2) + glow = onLayerL [levelInt,0] $ uncurry translate ep + $ color (withAlpha 0.01 red) + $ circleSolid 30 + sc = (*) 2 $ log $ 1 + fromIntegral time / 20 + s1 = (*) 2 $ log $ 2 + fromIntegral time / 40 + s2 = 0.5 * (sc + s1) + thepicture = pic <> piu <> pi2 <> glow + pi2 = onLayerL [levelInt,2] $ uncurry translate ep + $ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) + orange (dark red) + ) + $ rotate (radToDeg $ rot + 0.2 * fromIntegral time) + $ scale s2 s2 + $ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2) + + +doFlameDam :: Int -> Particle' -> Point2 -> Creature -> World -> World +doFlameDam amount pt p cr = over (creatures . ix (_crID cr) . crState . crDamage) + ((:) $ Flaming amount sp p ep) + where sp = _btPos' pt + ep = sp +.+ _btVel' pt + + + +makeSmokeAt :: Point2 -> World -> World +makeSmokeAt p w = over particles (IM.insert n smP) w + where n = newParticleKey w + smP = Particle + { _ptPos = p + , _ptStartPos = p + , _ptVel = (0,0) + , _ptPict = onLayer PtLayer $ uncurry translate p $ color black $ circleSolid 1 + --, _ptPict = uncurry translate p $ color white $ circleSolid 30 + , _ptID = n + , _ptUpdate = moveSmoke p 20 n + } + +moveSmoke :: Point2 -> Int -> Int -> World -> World +moveSmoke p time i | time > 0 = + set (particles . ix i . ptPict) pic . set (particles . ix i . ptUpdate) (moveSmoke p (time-1) i) + | time > -50 = + set (particles . ix i . ptPict) pi1 . set (particles . ix i . ptUpdate) (moveSmoke p (time-1) i) + | otherwise = + over particles (IM.delete i) + + where pic = onLayer PtLayer $ uncurry translate p $ color (greyN 0.5) $ circleSolid $ 21 - fromIntegral time + pi1 = onLayer PtLayer $ uncurry translate p + $ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5)) + $ circleSolid $ 21 + +makeSmokeAt' :: Float -> Int -> Point2 -> World -> World +makeSmokeAt' scal time p w = over particles (IM.insert n smP) w + where n = newParticleKey w + smP = Particle + { _ptPos = p + , _ptStartPos = p + , _ptVel = (0,0) + , _ptPict = onLayer PtLayer $ uncurry translate p $ color black $ circleSolid 1 + , _ptID = n + , _ptUpdate = moveSmoke' scal p time n + } + +moveSmoke' :: Float -> Point2 -> Int -> Int -> World -> World +moveSmoke' scal p time i + | time > 0 + = set (particles . ix i . ptPict) pic + . set (particles . ix i . ptUpdate) (moveSmoke' scal p (time-1) i) + | time > -50 + = set (particles . ix i . ptPict) pi1 + . set (particles . ix i . ptUpdate) (moveSmoke' scal p (time-1) i) + | otherwise + = over particles (IM.delete i) + where pic = onLayer PtLayer $ uncurry translate p $ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal + pi1 = onLayer PtLayer $ uncurry translate p + $ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5)) + $ circleSolid $ 21 * scal + +makeSmokeAt'' :: Point2 -> Float -> Int -> Point2 -> World -> World +makeSmokeAt'' vel scal time p w = over particles' ((:) smokeP) w + where smokeP = Particle' + { _ptPict' = onLayerL [levLayer PtLayer - 1] $ uncurry translate p $ color black $ circleSolid 1 + , _ptUpdate' = moveSmoke'' scal time p vel + } + +moveSmoke'' :: Float -> Int -> Point2 -> Point2 -> World -> Particle' -> (World, Maybe Particle') +moveSmoke'' scal time p vel w pt + | time > 0 = (w, Just $ pt { _ptPict' = pic + , _ptUpdate' = moveSmoke'' scal (time-1) pNew vel + }) + | time > -50 = (w, Just $ pt { _ptPict' = pi1 + , _ptUpdate' = moveSmoke'' scal (time-1) pNew vel + }) + | otherwise = (w, Nothing) + where pNew = p +.+ vel + pic = onLayerL [levLayer PtLayer - 1] + $ uncurry translate pNew + $ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal + pi1 = (onLayerL [levLayer PtLayer] + $ uncurry translate pNew + $ color (withAlpha (0.3 * (1 + fromIntegral time /50)) (greyN 0.5)) + $ circleSolid $ 21 * scal) + <> (onLayerL [levLayer BgLayer+1] + $ uncurry translate pNew + $ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5)) + $ circleSolid $ 21 * scal) + +makeColorSmokeAt :: Color -> Point2 -> Float -> Int -> Point2 -> World -> World +makeColorSmokeAt col vel scal time p w = over particles (IM.insert n smP) w + where n = newParticleKey w + smP = Particle + { _ptPos = p + , _ptStartPos = p + , _ptVel = vel + , _ptPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 1 + , _ptID = n + , _ptUpdate = moveColorSmoke col scal time n + } + +moveColorSmoke :: Color -> Float -> Int -> Int -> World -> World +moveColorSmoke col scal time i w + | time > 0 + = set (particles . ix i . ptPict) pic + . set (particles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i) + . set (particles . ix i . ptPos) newPos + . setVel + $ w + | time > -50 + = set (particles . ix i . ptPict) pi1 + . set (particles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i) + . set (particles . ix i . ptPos) newPos + . setVel + $ w + | otherwise + = over particles (IM.delete i) w + where oldPos = _ptPos $ _particles w IM.! i + newPos = oldPos +.+ (_ptVel $ _particles w IM.! i) + setVel = over (particles . ix i . ptVel) $ (*.*) 0.99 + pic = onLayer PtLayer $ uncurry translate newPos $ color col $ circleSolid $ (21 - fromIntegral time) * scal + pi1 = onLayer PtLayer $ uncurry translate newPos + $ color (withAlpha (1 + fromIntegral time /50) col) + $ circleSolid $ 21 * scal + + +thingHit :: Point2 -> Maybe (Point2,a,b) -> Maybe (Point2,c) -> Maybe (Either (Point2,a,b) (Point2,c)) +thingHit p Nothing Nothing = Nothing +thingHit p (Just x) Nothing = Just (Left x) +thingHit p Nothing (Just x) = Just (Right x) +thingHit p (Just x@(p1,_,_)) (Just y@(p2,_)) + | magV (p -.- p1) > magV (p -.- p2) = Just (Right y) + | otherwise = Just (Left x) + + +damCrsOnLine :: Int -> Point2 -> Point2 -> World -> World +damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine) + where damIfOnLine cr | circOnLine p1 p2 (_crPos cr) (_crRad cr) + = over crHP (\hp -> hp - dam) cr + | otherwise = cr diff --git a/src/EventHelper.hs b/src/EventHelper.hs new file mode 100644 index 000000000..cef256c18 --- /dev/null +++ b/src/EventHelper.hs @@ -0,0 +1,11 @@ +module EventHelper where +import SDL + +stripTimestamp :: (world -> EventPayload -> Maybe world) + -> world -> Event -> Maybe world +stripTimestamp f w e = f w (eventPayload e) + +test :: world -> EventPayload -> Maybe world +test w e = case e of + KeyboardEvent (KeyboardEventData _ Pressed _ (Keysym _ KeycodeReturn _)) -> Nothing + _ -> Just w diff --git a/src/Geometry.hs b/src/Geometry.hs new file mode 100644 index 000000000..7bbfa5120 --- /dev/null +++ b/src/Geometry.hs @@ -0,0 +1,576 @@ +{-# LANGUAGE BangPatterns #-} +module Geometry + ( module Geometry + , module Geometry.Data + ) + where +import Geometry.Data + +import Data.Function +import Data.List +import Data.Maybe + +import Control.Applicative + +zeroZ :: Point2 -> Point3 +zeroZ (x,y) = (x,y,0) + +infixl 6 +.+, -.- +infixl 7 *.* + +(+.+) :: Point2 -> Point2 -> Point2 +{-# INLINE (+.+) #-} +(x1, y1) +.+ (x2, y2) = + let + !x = x1 + x2 + !y = y1 + y2 + in (x, y) + +(-.-) :: Point2 -> Point2 -> Point2 +{-# INLINE (-.-) #-} +(x1, y1) -.- (x2, y2) = + let + !x = x1 - x2 + !y = y1 - y2 + in (x, y) + +(*.*) :: Float -> Point2 -> Point2 +{-# INLINE (*.*) #-} +a *.* (x2, y2) = + let + !x = a * x2 + !y = a * y2 + in (x, y) + +infixl 6 +.+.+, -.-.- +infixl 7 *.*.* + +(+.+.+) :: Point3 -> Point3 -> Point3 +{-# INLINE (+.+.+) #-} +(x1, y1, z1) +.+.+ (x2, y2, z2) = + let + !x = x1 + x2 + !y = y1 + y2 + !z = z1 + z2 + in (x, y, z) + +(-.-.-) :: Point3 -> Point3 -> Point3 +{-# INLINE (-.-.-) #-} +(x1, y1, z1) -.-.- (x2, y2, z2) = + let + !x = x1 - x2 + !y = y1 - y2 + !z = z1 - z2 + in (x, y, z) + +(*.*.*) :: Point3 -> Point3 -> Point3 +{-# INLINE (*.*.*) #-} +(x1, y1, z1) *.*.* (x2, y2, z2) = + let + !x = x1 * x2 + !y = y1 * y2 + !z = z1 * z2 + in (x, y, z) + +normalizeV :: Point2 -> Point2 +{-# INLINE normalizeV #-} +normalizeV p = (1 / magV p) *.* p + +angleVV :: Point2 -> Point2 -> Float +{-# INLINE angleVV #-} +angleVV a b = let ma = magV a + mb = magV b + d = a `dotV` b + in acos $ d / (ma * mb) + +dotV :: Point2 -> Point2 -> Float +{-# INLINE dotV #-} +dotV (x,y) (z,w) = x*z + y*w + +closestPointOnLine :: Point2 -> Point2 -> Point2 -> Point2 +{-# INLINE closestPointOnLine #-} +closestPointOnLine a b p + = a +.+ u *.* (b -.- a) + where u = closestPointOnLineParam a b p + +closestPointOnLineParam :: Point2 -> Point2 -> Point2 -> Float +{-# INLINE closestPointOnLineParam #-} +closestPointOnLineParam a b p + = (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a) + +argV :: Point2 -> Float +{-# INLINE argV #-} +argV (x,y) = normalizeAngle $ atan2 y x + +detV :: Point2 -> Point2 -> Float +{-# INLINE detV #-} +detV (x1, y1) (x2, y2) + = x1 * y2 - y1 * x2 + +-- | Angle in radians, anticlockwise from +ve x-axis. +unitVectorAtAngle :: Float -> Point2 +{-# INLINE unitVectorAtAngle #-} +unitVectorAtAngle r + = (cos r, sin r) + +-- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise. +rotateV :: Float -> Point2 -> Point2 +rotateV r (x, y) + = ( x * cos r - y * sin r + , x * sin r + y * cos r) +{-# INLINE rotateV #-} + +-- | Convert degrees to radians +degToRad :: Float -> Float +degToRad d = d * pi / 180 +{-# INLINE degToRad #-} + + +-- | Convert radians to degrees +radToDeg :: Float -> Float +radToDeg r = r * 180 / pi +{-# INLINE radToDeg #-} + + +-- | Normalize an angle to be between 0 and 2*pi radians +normalizeAngle :: Float -> Float +normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi)) + where floor' :: Float -> Float + floor' x = fromIntegral (floor x :: Int) +{-# INLINE normalizeAngle #-} + +-- the following helper draws a rectangle based on maximal N E S W values +rectNESW :: Float -> Float -> Float -> Float -> [Point2] +rectNESW a b c d = [(b,a),(b,c),(d,c),(d,a) + ] +rectNSEW n s e w = rectNESW n e s w + +rectNSWE :: Float -> Float -> Float -> Float -> [Point2] +rectNSWE n s w e = [ (w,n), (w,s), (e,s), (e,n)] + +-- -- the following filters points in a polygon: supposes the points in the +-- polygon are listed in anticlockwise order +pointInOrOnPolygon :: Point2 -> [Point2] -> Bool +pointInOrOnPolygon p (x:xs) = all (\l -> not (uncurry isRHS l p)) $ zip (x:xs) (xs ++ [x]) + + +pointInPolygon :: Point2 -> [Point2] -> Bool +pointInPolygon p [] = False +pointInPolygon p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x]) + +errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool +errorPointInPolygon i p xs | length xs == 1 = error "one point polygon" + | length xs == 2 = error "two point polygon" + | nub xs == xs = pointInPolygon p xs + | otherwise = error $ "errorPointInPolygon "++ show i + +errorNormalizeV :: Int -> Point2 -> Point2 +errorNormalizeV i (0,0) = error $ "problem with function: errorNormalizeV "++show i +errorNormalizeV i p = normalizeV p + +errorAngleVV :: Int -> Point2 -> Point2 -> Float +errorAngleVV i (0,0) _ = error $ "problem with function: errorAngleVV "++show i +errorAngleVV i _ (0,0) = error $ "problem with function: errorAngleVV "++show i +errorAngleVV i p p' = angleVV p p' + +errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool +errorIsLHS i x y | x == y = error $ "problem with function: errorIsLHS " + ++show i + | otherwise = isLHS x y + +errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2 +errorClosestPointOnLine i x y | x == y = error $ "problem with function: errorClosestPointOnLine " + ++show i + | otherwise = closestPointOnLine x y + +errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float +errorClosestPointOnLineParam i x y z | x == y = dist x z +-- error $ "problem with function: errorClosestPointOnLineParam " ++show i + | otherwise = closestPointOnLineParam x y z + +safeNormalizeV :: Point2 -> Point2 +safeNormalizeV (0,0) = (0,0) +safeNormalizeV p = normalizeV p + +-- tests whether a point is on the LHS of a line +-- this has been called somewhere with l1 == l2 +isLHS :: Point2 -> Point2 -> Point2 -> Bool +{-# INLINE isLHS #-} +isLHS' l1 l2 p | l1 == l2 = False + | otherwise = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p < 0 + +isLHS (x,y) (x',y') (x'',y'') + | (x,y) == (x',y') = False + | otherwise = a1 * b2 - a2 * b1 > 0 + where a1 = x' - x + a2 = y' - y + b1 = x'' - x + b2 = y'' - y + +isRHS :: Point2 -> Point2 -> Point2 -> Bool +{-# INLINE isRHS #-} +isRHS (x,y) (x',y') (x'',y'') + | (x,y) == (x',y') = False + | otherwise = a1 * b2 - a2 * b1 < 0 + where a1 = x' - x + a2 = y' - y + b1 = x'' - x + b2 = y'' - y +--isRHS l1 l2 p = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p > 0 + +-- reorders points to be anticlockwise around their center +orderPolygon :: [Point2] -> [Point2] +orderPolygon [] = [] +orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps + where cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps + +vNormal :: Point2 -> Point2 +{-# INLINE vNormal #-} +vNormal (x,y) = (y,-x) + +vInverse :: Point2 -> Point2 +vInverse (x,y) = (-x,-y) + +dist :: Point2 -> Point2 -> Float +{-# INLINE dist #-} +dist p1 p2 = magV (p2 -.- p1) + +normV :: Point2 -> Point2 +{-# INLINE normV #-} +normV (0,0) = (0,0) +normV p = (1/magV p ) *.* p + +magV :: Point2 -> Float +{-# INLINE magV #-} +magV (x,y) = sqrt $ x^2 + y^2 + +pHalf :: Point2 -> Point2 -> Point2 +pHalf a b = 0.5 *.* (a +.+ b) + +linGrad :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a +linGrad (x,y) (a,b) | x-a == 0 = Nothing + | otherwise = Just $ (y-b)/(x-a) + +axisInt :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a +axisInt p (a,b) = pure b ^-^ (pure a ^*^ linGrad p (a,b)) + where (^-^) = liftA2 (-) + (^*^) = liftA2 (*) + +-- intersectSegSeg is sometimes broken-- the following fixes at least some of +-- the cases +-- it is, however, slow +myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLineLine a b c d of + Nothing -> Nothing + Just (x,y) -> if inbetween x && inbetween' y + then Just (x,y) + else Nothing + where inbetween x = ((ax <= x && x <= bx) || (bx <= x && x <= ax)) && + ((cx <= x && x <= dx) || (dx <= x && x <= cx)) + inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) && + ((cy <= y && y <= dy) || (dy <= y && y <= cy)) + +crossV :: Point2 -> Point2 -> Float +crossV (ax,ay) (bx,by) = ax*by - ay*bx + +myIntersectLineLine :: (Eq a,Fractional a) => (a,a) -> (a,a) -> (a,a) -> (a,a) -> Maybe (a,a) +myIntersectLineLine a@(ax,ay) b c@(cx,cy) d + | linGrad a b == Nothing = fmap ((,) ax) $ axisInt (c *-* (ax,0)) (d *-* (ax,0)) + | linGrad c d == Nothing = fmap ((,) cx) $ axisInt (a *-* (cx,0)) (b *-* (cx,0)) + | otherwise + = case linGrad a b ^-^ linGrad c d of + Just 0 -> Nothing + _ -> liftA2 (,) newx + ((linGrad a b ^*^ newx) ^+^ axisInt a b) + where (^-^) = liftA2 (-) + (^+^) = liftA2 (+) + (^/^) = liftA2 (/) + (^*^) = liftA2 (*) + newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d) + (*-*) (ax,ay) (bx,by) = (ax-bx,ay-by) + +ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 +ratIntersectLineLine a b c d = fmap toNumPoint2 $ myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d) + where toRatPoint2 (x,y) = (toRational x, toRational y) + toNumPoint2 (x,y) = (fromRational x, fromRational y) + f = toRatPoint2 . roundPoint2 + +roundPoint2 :: Point2 -> Point2 +roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y) + +circOnLine' :: Point2 -> Point2 -> Point2 -> Float -> Bool +circOnLine' p1 p2 c rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) + where y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2)) + isJustTrue (Just True) = True + isJustTrue _ = False + +circOnLine :: Point2 -> Point2 -> Point2 -> Float -> Bool +circOnLine p1 p2 c rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad + || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) + where y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2)) + isJustTrue (Just True) = True + isJustTrue _ = False + +difference x y | x > y = x - y + | otherwise = y - x + +reflectIn :: Point2 -> Point2 -> Point2 +reflectIn line vec = let angle = 2 * angleBetween line vec + in rotateV angle vec + +angleBetween v1 v2 = argV v1 - argV v2 + +doublePair :: (a,a) -> [(a,a)] +doublePair (x,y) = [(x,y),(y,x)] + +polysIntersect :: [Point2] -> [Point2] -> Bool +polysIntersect (p:ps) (q:qs) + = any isJust $ (\(a,b) (c,d) -> myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2 + where pairs1 = zip (p:ps) (ps++[p]) + pairs2 = zip (q:qs) (qs++[q]) + +anyPolyssIntersect :: [[Point2]] -> [[Point2]] -> Bool +anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y + +nRays :: Int -> [Point2] +nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) $ (600,0) + +nRaysRad :: Int -> Float -> [Point2] +nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) $ (x,0) + +-- angles go from 0 to 2pi, need to work out what is left of another + +isLeftOfA :: Float -> Float -> Bool +isLeftOfA angle1 angle2 = (angle1 - angle2 < pi && angle1 > angle2) + || (angle2 - angle1 > pi && angle2 > angle1) + +isLeftOf :: Point2 -> Point2 -> Bool +isLeftOf x y = isLeftOfA (argV x) (argV y) + +-- diffAngles has an issue... + +diffAngles :: Float -> Float -> Float +diffAngles x y | diff > pi = diffAngles (x - 2*pi) y + | diff >= 0 = diff + | diff > -pi = -diff + | otherwise = diffAngles (x + 2*pi) y + where diff = x-y +differenceAngles = diffAngles +angleDifference = diffAngles + +-- given a triangle where we know the length of a first side, +-- the length of a second side, and the angle between the first side and the +-- third side, finds the length of the third side +-- not this doesn't necessarily find ALL solutions, asin is a map not a function +ssaTri :: Float -> Float -> Float -> Float +ssaTri ab bc a + | sin a == 0 = 0 + | bc == 0 = ab + | otherwise = let c = asin ( (ab * (sin a))/bc) + b = pi - (a + c) + in sin b * bc / sin a + +-- fix points: we now fix the triangle in the coordinate system, and return a +-- third unknown point: +-- the point which lies between pa and pc' on a line from b of length bc +-- note that there are likely two such points, this seems to return the point +-- closer to pc' + +ssaTriPoint :: Point2 -> Point2 -> Point2 -> Float -> Point2 +ssaTriPoint pa pb pc' bc + = let ab = magV (pa -.- pb) + a = errorAngleVV 6 (pb -.- pa) (pc' -.- pa) + ac = ssaTri ab bc a + in pa +.+ (ac *.* errorNormalizeV 47 (pc' -.- pa)) + +-- the above SHOULD return a Maybe Point... +ssaTriPoint' :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2 +ssaTriPoint' pa pb pc' bc + | dist pb (closestPointOnSeg pa pc' pb) >= bc + = Nothing + | otherwise + = Just $ ssaTriPoint pa pb pc' bc +ssaTriPointCorrect :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2 +ssaTriPointCorrect pa pb pc' bc + | param <= 1 && param >= 0 = Just p + | otherwise = Nothing + where p = ssaTriPoint pa pb pc' bc + param = closestPointOnLineParam pa pc' p + + +closestPointOnSeg :: Point2 -> Point2 -> Point2 -> Point2 +closestPointOnSeg segP1 segP2 p + | errorClosestPointOnLineParam 3 segP1 segP2 p <= 0 = segP1 + | errorClosestPointOnLineParam 4 segP1 segP2 p >= 1 = segP2 + | otherwise = errorClosestPointOnLine 2 segP1 segP2 p + +pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2 +pointInCircle p r c | p == c = Just p + | magV (p -.- c) < r = Just p + | otherwise = Nothing + +--determines if a moving point intersects with a circle, +--if so, returns a point on circle that intersects with the line passing +--throught the circle : HOPEFULLY THE CORRECT OF THE TWO! + +collidePointCirc :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2 +collidePointCirc p1 p2 rad c = ssaTriPoint' p2 c p1 rad + +-- changes the point to a measure of the distance +collidePointCirc' :: Point2 -> Point2 -> Float -> Point2 -> Maybe Float +collidePointCirc' p1 p2 rad c = fmap (\x -> magV (x -.- p1)) + (collidePointCirc p1 p2 rad c) + +--returns both the point and the measure of the distance +collidePointCirc'' :: Point2 -> Point2 -> Float -> Point2 -> Maybe (Point2,Float) +collidePointCirc'' p1 p2 rad c = (,) <$> collidePointCirc p1 p2 rad c + <*> collidePointCirc' p1 p2 rad c + +collidePointCircCorrect :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2 +collidePointCircCorrect p1 p2 rad c = ssaTriPointCorrect p2 c p1 rad + + +-- finds the height of a triangle using herons formula +-- the base is the line between the first two points +heron :: Point2 -> Point2 -> Point2 -> Float +heron x y z | x == y = 0 + | otherwise = let a = magV $ x -.- y + b = magV $ y -.- z + c = magV $ z -.- x + s = (a+b+c)/2 + area = sqrt(s*(s-a)*(s-b)*(s-c)) + in 2*area/a +-- multiplies reflection in normal by factor +reflectInParam :: Float -> Point2 -> Point2 -> Point2 +reflectInParam x line vec = let angle = 2 * angleBetween line vec + rAng = rotateV angle vec + p = x *.* errorClosestPointOnLine 3 (0,0) (vNormal line) rAng + in rAng -.- p + + +reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 +reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1) + +isOnLine :: Point2 -> Point2 -> Point2 -> Bool +isOnLine l1 l2 p = errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0 + && errorClosestPointOnLineParam 11 l1 l2 p <= 1 + && errorClosestPointOnLineParam 12 l1 l2 p >= 0 + +-- the take 5000 here is a hack, otherwise divideLine seems to sometimes +-- generate an infinite list, and I don't know why +divideLine :: Float -> Point2 -> Point2 -> [Point2] +--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) +divideLine x a b = take 5000 $ map (\i -> a +.+ (i / (fromIntegral numPoints) *.* (b -.- a)) ) + $ map fromIntegral ns + where d = dist a b + numPoints = max 1 $ ceiling $ d / x + ns = [0 .. numPoints] + + +-- pulled the following from the haskell wiki +bresenham :: (Int,Int) -> (Int,Int) -> [(Int,Int)] +{-# INLINE bresenham #-} +bresenham pa@(xa,ya) pb@(xb,yb) = map maySwitch . unfoldr go $ (x1,y1,0) + where + steep = abs (yb - ya) > abs (xb - xa) + maySwitch = if steep then (\(x,y) -> (y,x)) else id + [(x1,y1),(x2,y2)] = sort [maySwitch pa, maySwitch pb] + deltax = x2 - x1 + deltay = abs (y2 - y1) + ystep = if y1 < y2 then 1 else -1 + go (xTemp, yTemp, error) + | xTemp > x2 = Nothing + | otherwise = Just ((xTemp, yTemp), (xTemp + 1, newY, newError)) + where + tempError = error + deltay + (newY, newError) = if (2*tempError) >= deltax + then (yTemp+ystep,tempError-deltax) + else (yTemp,tempError) + + +divideCircle :: Float -> Point2 -> Float -> [Point2] +divideCircle x cen rad = map (cen +.+) $ nPointsOnCirc n rad + where n = ceiling $ rad * 2 * pi / x + +nPointsOnCirc :: Int -> Float -> [Point2] +nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) $ (rad,0) + +lineInPolygon :: Point2 -> Point2 -> [Point2] -> Bool +lineInPolygon a b ps = pointInPolygon a ps || pointInPolygon b ps + || any (isJust . uncurry (intersectSegSeg' a b)) pss + where pss = zip ps (tail ps ++ [head ps]) + +--intersectSegLineFrom :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 +--intersectSegLineFrom a b c d +-- = case intersectSegLine a b c d of +-- Just p | closestPointOnLineParam c d p >= 0 -> Just p +-- | otherwise -> Nothing +-- Nothing -> Nothing + +intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 +{-# INLINE intersectSegSeg' #-} +intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4) +-- | t' < 0 || u' < 0 || t' > den || u' > den || den == 0 +-- = Nothing + | den == 0 = Nothing + | den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den) + = Nothing + | den < 0 && (t' > 0 || u' > 0 || t' < den || u' < den) + = Nothing +-- | den > 0 && (t' < 0 || t' > den) +-- = Nothing +-- | den < 0 && (t' > 0 || t' < 0-den) +-- = Nothing + | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) + where + den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) + t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) + u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) + +intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 +{-# INLINE intersectSegLineFrom' #-} +intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4) +-- | t' < 0 || u' < 0 || t' > den || u' > den || den == 0 +-- = Nothing + | den == 0 = Nothing + | den > 0 && ( t' < 0 || u' < 0 || t' > den ) + = Nothing + | den < 0 && ( t' > 0 || u' > 0 || t' < den ) + = Nothing +-- | den > 0 && (t' < 0 || t' > den) +-- = Nothing +-- | den < 0 && (t' > 0 || t' < 0-den) +-- = Nothing + | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) + where + den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) + t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) + u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) + +intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 +{-# INLINE intersectSegLine' #-} +intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) +-- | t' < 0 || u' < 0 || t' > den || u' > den || den == 0 +-- = Nothing + | den == 0 = Nothing + | den > 0 && (t' < 0 || t' > den) + = Nothing + | den < 0 && (t' > 0 || t' < den) + = Nothing +-- | den > 0 && (t' < 0 || t' > den) +-- = Nothing +-- | den < 0 && (t' > 0 || t' < 0-den) +-- = Nothing + | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) + where + den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) + t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) + u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) + +intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 +{-# INLINE intersectLineLine' #-} +intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) + | den == 0 = Nothing + | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den) + where + den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) + t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) diff --git a/src/Geometry/Data.hs b/src/Geometry/Data.hs new file mode 100644 index 000000000..6e8029175 --- /dev/null +++ b/src/Geometry/Data.hs @@ -0,0 +1,8 @@ +module Geometry.Data + ( Point2 (..) + , Point3 (..) + ) + where + +type Point2 = (Float,Float) +type Point3 = (Float,Float,Float) diff --git a/src/Loop.hs b/src/Loop.hs new file mode 100644 index 000000000..c5dc64f5c --- /dev/null +++ b/src/Loop.hs @@ -0,0 +1,120 @@ +module Loop + ( setupLoop +-- , withExits + ) where +import SDL +import qualified Data.Text as T +import Control.Concurrent +import Control.Exception +import qualified Graphics.Rendering.OpenGL as GL +import Control.Monad +import System.Mem +import Foreign.C +import Geometry + +winConfig x y = defaultWindow + { windowGraphicsContext + = OpenGLContext (defaultOpenGL { glProfile = Core Normal 4 3 + , glColorPrecision = V4 8 8 8 8 + } + ) + , windowInitialSize = V2 x y + , windowResizable =True + } + +setupLoop :: String + -> CInt + -> CInt + -> IO setupParams + -> (setupParams -> IO ()) + -> world + -> (setupParams -> world -> IO ()) + -> (world -> Event -> Maybe world) + -> (world -> Maybe world) + -> IO () +setupLoop wName xSize ySize + customInit initCleanup startWorld sideEffects eventFn worldFn = do + initializeAll + bracket (createWindow (T.pack wName) (winConfig xSize ySize)) destroyWindow + (\window -> + do bracket (glCreateContext window) (\con -> GL.finish >> glDeleteContext con) + (\_ -> bracket customInit initCleanup $ \setup -> do -- setup <- customInit +-- swapInterval $= ImmediateUpdates + GL.blend $= GL.Enabled + GL.blendEquation $= GL.FuncAdd + GL.blendFunc $= (GL.SrcAlpha,GL.OneMinusSrcAlpha) + GL.clearColor $= GL.Color4 0 0.5 0 0 + doLoop setup window startWorld + sideEffects eventFn worldFn + ) + ) + + +--doLoop :: setupParams -> Window -> WorldView world0 +-- -> (setupParams -> WorldView world0 -> IO ()) +-- -> (world0 -> Event -> Maybe world0) +-- -> (world0 -> Maybe world0) +-- -> IO () +doLoop setup window startWorld + worldSideEffects + eventFn + worldUpdate + = do + startLoopTicks <- ticks + events <- pollEvents + --let-- maybeUpdatedWorld :: Maybe (WorldView world0) + -- maybeUpdatedWorld = applyEvents eventFn startWorld events worldUpdate + maybeUpdatedWorld <- applyEventsIO eventFn startWorld events + case maybeUpdatedWorld >>= worldUpdate of + Just updatedWorld -> do + GL.clear [GL.ColorBuffer,GL.DepthBuffer] + worldSideEffects setup updatedWorld + glSwapWindow window + --GL.flush + performGC + endLoopTicks <- ticks -- it might be better to use System.Clock (monotonic) + let delay = max 0 (10 + fromIntegral startLoopTicks - fromIntegral endLoopTicks) + threadDelay (delay * 1000) + doLoop setup window updatedWorld worldSideEffects eventFn worldUpdate + Nothing -> return () + +applyEvents :: (world0 -> Event -> Maybe world0) + -> world0 + -> [Event] + -> (world0 -> Maybe world0) + -> Maybe world0 +applyEvents eventFn startWorld events worldUpdate = + case foldM (applyH eventFn) startWorld events of + Just w -> fmap (\w' -> w') $ worldUpdate w + Nothing -> Nothing + where + applyH :: (world0 -> Event -> Maybe world0) -> world0 -> Event -> Maybe world0 + applyH f w e + = case eventPayload e of + QuitEvent -> Nothing + WindowClosedEvent _ -> Nothing + _ -> f w e + +-- applyResizeExits :: (world -> Event -> Maybe world) -> (world -> Event -> Maybe world) +-- applyResizeExits f w e +-- = case eventPayload e of +-- QuitEvent -> Nothing +-- WindowClosedEvent _ -> Nothing +-- WindowSizeChangedEvent +-- (WindowSizeChangedEventData {windowSizeChangedEventWindow = V2 x y}) +-- -> GL.viewport +-- _ -> f w e +applyEventIO :: (world -> Event -> Maybe world) -> Maybe world -> Event -> IO (Maybe world) +applyEventIO fn mw e = case eventPayload e of + QuitEvent -> return Nothing + WindowClosedEvent _ -> return Nothing + WindowSizeChangedEvent + (WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y}) + -> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (mw >>= \w -> fn w e) + _ -> return $ mw >>= flip fn e + +applyEventsIO :: (world0 -> Event -> Maybe world0) + -> world0 + -> [Event] + -> IO (Maybe world0) +applyEventsIO fn w es = foldM (applyEventIO fn) (Just w) es diff --git a/src/Picture.hs b/src/Picture.hs new file mode 100644 index 000000000..ce2abc136 --- /dev/null +++ b/src/Picture.hs @@ -0,0 +1,249 @@ +--{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Strict #-} +module Picture + ( module Picture.Data + , polygon + , arc + , arcSolid + , thickArc + , thickCircle + , circleSolid + , circle + , line + , text + , pictures + , translate + , rotate + , rotateRad + , scale + , blank + , color + , withAlpha + , greyN + , red + , green + , blue + , yellow + , cyan + , magenta + , rose + , violet + , azure + , aquamarine + , chartreuse + , orange + , white + , black + , dim + , light + , dark + , bright + , mixColors + , zeroZ + , setDepth + ) + where +import Geometry +import Geometry.Data + +import Picture.Data + +import Data.Bifunctor +import qualified Data.DList as DL + +import Graphics.Rendering.OpenGL (lineWidth, ($=),PrimitiveMode (..)) + +import Control.Lens + +black :: RGBA +black = (0,0,0,1) + +polygonD :: Float -> [Point2] -> Picture +{-# INLINE polygonD #-} +polygonD d (a:b:c:ps) = blank + { _scPosTri = DL.fromList $ map (\(x,y) -> (x,y,d)) tris + , _scColTri = DL.fromList $ map (const black) tris + } + where twoPs = zip (b:c:ps) (c:ps) + tris = concatMap (\(x,y)-> [a,x,y]) twoPs +polygonD _ _ = blank + +polygon :: [Point2] -> Picture +{-# INLINE polygon #-} +polygon (a:b:c:ps) = blank + { _scPosTri = DL.fromList $ map zeroZ tris + , _scColTri = DL.fromList $ map (const black) tris + } + where twoPs = zip (b:c:ps) (c:ps) + tris = concatMap (\(x,y)-> [a,x,y]) twoPs +polygon _ = blank + +color :: RGBA -> Picture -> Picture +{-# INLINE color #-} +color c = over scColTri (DL.map $ const c) . over scColChar (DL.map $ const c) + +translate3 :: Float -> Float -> Point3 -> Point3 +{-# INLINE translate3 #-} +translate3 a b (x,y,z) = (x+a,y+b,z) + +translate :: Float -> Float -> Picture -> Picture +{-# INLINE translate #-} +translate x y = over scPosTri (DL.map $ translate3 x y) . over scPosChar (DL.map $ translate3 x y) + +setDepth :: Float -> Picture -> Picture +setDepth d = over scPosTri (DL.map $ (\(x,y,z)->(x,y,d))) + . over scPosChar (DL.map $ (\(x,y,z)->(x,y,d))) + +--overVs' :: (CPoint2 -> CPoint) -> Picture -> Picture +----{-# INLINE overVs' #-} +--overVs' f !(Scene a b) = let !a' = map f a +-- !b' = map g b +-- in Scene a' b' +-- where g !(x,y,z) = let !(x',y') = f (x,y) +-- in (x',y',z) + +scale3 :: Float -> Float -> Point3 -> Point3 +{-# INLINE scale3 #-} +scale3 a b (x,y,z) = (x*a,y*b,z) + +scale :: Float -> Float -> Picture -> Picture +{-# INLINE scale #-} +scale x y = over scPosTri (DL.map $ scale3 x y) . over scPosChar (DL.map $ scale3 x y) + +rotate3 :: Float -> Point3 -> Point3 +{-# INLINE rotate3 #-} +rotate3 a (x,y,z) = (x',y',z) + where (x',y') = rotateV a (x,y) + +rotate :: Float -> Picture -> Picture +{-# INLINE rotate #-} +rotate a = over scPosTri (DL.map $ rotate3 (0 - degToRad a)) + . over scPosChar (DL.map $ rotate3 (0 - degToRad a)) + +-- -- this rotation uses radians, and is anticlockwise +rotateRad :: Float -> Picture -> Picture +{-# INLINE rotateRad #-} +rotateRad a = over scPosTri (DL.map $ rotate3 a) + . over scPosChar (DL.map $ rotate3 a) + +pictures :: [Picture] -> Picture +{-# INLINE pictures #-} +pictures = mconcat + + +makeArc :: Float -> (Float,Float) -> [Point2] +{-# INLINE makeArc #-} +makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad) + where as = [a,a+step.. b] + step = pi * 0.1 + +circleSolidD :: Float -> Float -> Picture +circleSolidD d r = polygonD d $ makeArc r (0,2*pi) + +circleSolid :: Float -> Picture +{-# INLINE circleSolid #-} +circleSolid rad = polygon $ makeArc rad (0,2*pi) + +circle :: Float -> Picture +{-# INLINE circle #-} +circle rad = line $ makeArc rad (0,2*pi) + +--text :: String -> Picture +--text s = zipWith (\x -> overVs $ first $ translate3 x 0) +-- [0,0.25..] +-- $ map charToShape s + +text :: String -> Picture +{-# INLINE text #-} +text s = mconcat $ zipWith (\x -> translate x (0-dimText)) + [0,0.9*dimText..] + (map charToScene s) + +charToScene :: Char -> Picture +charToScene c = Scene + {_scPosTri = DL.empty + ,_scColTri = DL.empty + ,_scPosChar = DL.fromList [(0.0 ,0.0 ,0) + ,(dimText,0.0 ,0) + ,(dimText,dimText*2,0) + ,(0.0 ,0.0 ,0) + ,(dimText,dimText*2,0) + ,(0.0 ,dimText*2,0) + ] + ,_scColChar = DL.fromList $ take 6 $ repeat white + ,_scTexChar = DL.fromList $ [(s,1) ,(e,1) ,(e,0) ,(s,1) ,(e,0) ,(s,0)] + } + where x = 1/128 + s = offset * x + e = s + x + offset = fromIntegral (fromEnum c) - 32 + + +dimText = 100 + +line :: [Point2] -> Picture +{-# INLINE line #-} +line ps = thickLine ps 1 + +thickLine :: [Point2] -> Float -> Picture +{-# INLINE thickLine #-} +thickLine ps x = blank + +thickCircle :: Float -> Float -> Picture +{-# INLINE thickCircle #-} +thickCircle rad wdth = thickLine (makeArc rad (0,2*pi)) wdth + +arcSolid :: Float -> Float -> Float -> Picture +{-# INLINE arcSolid #-} +arcSolid startA endA rad + = polygon $ (0,0) : makeArc rad (startA,endA) + +arc startA endA rad = thickArc startA endA rad 1 +{-# INLINE arc #-} + +thickArc :: Float -> Float -> Float -> Float -> Picture +{-# INLINE thickArc #-} +thickArc startA endA rad wdth + = thickLine (makeArc rad (startA,endA)) wdth + +withAlpha :: Float -> RGBA -> RGBA +{-# INLINE withAlpha #-} +withAlpha a (x,y,z,a') = (x,y,z,a*a') + +red,green,blue,yellow,cyan,magenta,rose,violet,azure,aquamarine,chartreuse,orange,white::Color +red = (1,0,0,1) +green = (0,1,0,1) +blue = (0,0,1,1) +yellow = (1,1,0,1) +cyan = (0,1,1,1) +magenta = (1,0,1,1) +rose = (1,0,0.5,1) +violet = (0.5,0,1,1) +azure = (0,0.5,1,1) +aquamarine= (0,1,0.5,1) +chartreuse= (0.5,1,0,1) +orange = (1,0.5,0,1) +white = (1,1,1,1) + +mixColors :: Float -> Float -> Color -> Color -> Color +mixColors rata ratb (r0,g0,b0,a0) (r2,g2,b2,a2) = + let fullrat = rata + ratb + normrata = rata / fullrat + normratb = ratb / fullrat + f x y = sqrt $ normrata * x^2 + normratb * y^2 + in (f r0 r2 , f g0 g2 , f b0 b2 , normrata * a0 + normratb * a2) + +light :: Color -> Color +light (r,g,b,a) = (r+0.2,g+0.2,b+0.2,a) + +dark :: Color -> Color +dark (r,g,b,a) = (r-0.2,g-0.2,b-0.2,a) + +dim :: Color -> Color +dim (r,g,b,a) = (r/1.2,g/1.2,b/1.2,a) + +bright :: Color -> Color +bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a) + +greyN :: Float -> Color +greyN x = (x,x,x,1) diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs new file mode 100644 index 000000000..c97579ff0 --- /dev/null +++ b/src/Picture/Data.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Strict #-} +module Picture.Data + where +import Data.Monoid +import qualified Data.DList as DL +import Geometry.Data + +import Control.Lens + +type RGBA = (Float,Float,Float,Float) +type Color = (Float,Float,Float,Float) + +data Picture = Scene + { _scPosTri :: DL.DList Point3 + , _scColTri :: DL.DList RGBA + , _scPosChar :: DL.DList Point3 + , _scColChar :: DL.DList RGBA + , _scTexChar :: DL.DList Point2 + } + +blank :: Picture +{-# INLINE blank #-} +blank = Scene DL.empty DL.empty DL.empty DL.empty DL.empty + +combineScenes :: Picture -> Picture -> Picture +{-# SCC combineScenes #-} +--{-# INLINE combineScenes #-} +combineScenes sa sb = Scene + { _scPosTri = _scPosTri sa <> _scPosTri sb + , _scColTri = _scColTri sa <> _scColTri sb + , _scPosChar = _scPosChar sa <> _scPosChar sb + , _scColChar = _scColChar sa <> _scColChar sb + , _scTexChar = _scTexChar sa <> _scTexChar sb + } + +instance Semigroup Picture where + (<>) = combineScenes +instance Monoid Picture where + mempty = blank + --mappend = combineScenes + +makeLenses ''Picture diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs new file mode 100644 index 000000000..89c63f0f3 --- /dev/null +++ b/src/Picture/Preload.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Strict #-} +module Picture.Preload + where + +import Codec.Picture +import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth) +import qualified Graphics.Rendering.OpenGL as GL + +import qualified Data.Vector.Storable as V + +import Control.Lens + +import Foreign + +import Shaders + +data PreloadData = PreloadData + { _charMap :: Image PixelRGBA8 +-- , _textures :: [Image PixelRGBA8] + , _basicShader :: Program + , _textShader :: Program + , _fadeCircleShader :: Program + , _basicVAO :: VertexArrayObject + , _textVAO :: VertexArrayObject + , _posVBO :: BufferObject + , _colVBO :: BufferObject + , _texVBO :: BufferObject + , _ptrPosVBO :: Ptr Float + , _ptrColVBO :: Ptr Float + , _ptrTexVBO :: Ptr Float + } + +makeLenses ''PreloadData + + +loadTextures :: IO [Image PixelRGBA8] +loadTextures = do +-- echarMap <- readImage "data/texture/smudgedDirt.png" + echarMap <- readImage "data/texture/charMap.png" + case echarMap of + Left err -> do + putStrLn err + return [] + Right charMap -> + return [convertRGBA8 charMap] + +bufferOffset :: Integral a => a -> Ptr b +bufferOffset = plusPtr nullPtr . fromIntegral + +doPreload' :: IO PreloadData +doPreload' = do +-- compile shader programs + bs <- makeBasicShader + ts <- makeTextureShader + fcs <- makeFadeShader + +--setup vbos +--need to be bound before assigning the vertex attribute pointers + posVBO <- genObjectName + colVBO <- genObjectName + texVBO <- genObjectName + +-- load charmap as texture +-- Right cmap <- readImage "data/texture/smudgedDirt.png" + Right cmap <- readImage "data/texture/charMap.png" + let tex = convertRGBA8 cmap + texo <- genObjectName + textureBinding Texture2D $= Just texo + let texData = V.toList $ imageData tex + wtex = fromIntegral $ imageWidth tex + htex = fromIntegral $ imageHeight tex + withArray texData $ \ptr -> do + texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D wtex htex) 0 + (PixelData RGBA UnsignedByte ptr) + generateMipmap' Texture2D + textureFilter Texture2D $= ((Linear',Just Linear') , Nearest) + + let vertexSize = sizeOf (0.5 :: GLfloat) + firstIndex = 0 + +-- setup VAOs: basic vao + basicVAO <- genObjectName + bindVertexArrayObject $= Just basicVAO + +-- let posAttrib = AttribLocation 0 +-- colAttrib = AttribLocation 1 + bindBuffer ArrayBuffer $= Just posVBO + vertexAttribPointer (AttribLocation 0) $= + ( ToFloat + , VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 3) + (bufferOffset (firstIndex * vertexSize)) + ) + vertexAttribArray (AttribLocation 0) $= Enabled + + bindBuffer ArrayBuffer $= Just colVBO + vertexAttribPointer (AttribLocation 1) $= + ( ToFloat + , VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 4) + (bufferOffset (firstIndex * vertexSize) ) + ) + vertexAttribArray (AttribLocation 1) $= Enabled + +-- setup second vao + textVAO <- genObjectName + bindVertexArrayObject $= Just textVAO + + bindBuffer ArrayBuffer $= Just posVBO + vertexAttribPointer (AttribLocation 0) $= + ( ToFloat + , VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 3) + (bufferOffset (firstIndex * vertexSize)) + ) + vertexAttribArray (AttribLocation 0) $= Enabled + + bindBuffer ArrayBuffer $= Just colVBO + vertexAttribPointer (AttribLocation 1) $= + ( ToFloat + , VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 4) + (bufferOffset (firstIndex * vertexSize) ) + ) + vertexAttribArray (AttribLocation 1) $= Enabled + + bindBuffer ArrayBuffer $= Just texVBO + vertexAttribPointer (AttribLocation 2) $= + ( ToFloat + , VertexArrayDescriptor 2 Float (fromIntegral $ vertexSize * 2) + (bufferOffset (firstIndex * vertexSize) ) + ) + vertexAttribArray (AttribLocation 2) $= Enabled + +-- allocate memory for vertex attributes + ptrPosVBO <- mallocArray (3*3*5000) + ptrColVBO <- mallocArray (3*4*5000) + ptrTexVBO <- mallocArray (3*2*5000) + + return $ PreloadData + { _charMap = convertRGBA8 cmap + , _basicShader = bs + , _textShader = ts + , _fadeCircleShader = fcs + , _basicVAO = basicVAO + , _textVAO = textVAO + , _posVBO = posVBO + , _colVBO = colVBO + , _texVBO = texVBO + , _ptrPosVBO = ptrPosVBO + , _ptrColVBO = ptrColVBO + , _ptrTexVBO = ptrTexVBO + } + +cleanUpPreload :: PreloadData -> IO () +cleanUpPreload pd = do + free (_ptrPosVBO pd) + free (_ptrColVBO pd) + free (_ptrTexVBO pd) diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs new file mode 100644 index 000000000..b77a02597 --- /dev/null +++ b/src/Picture/Render.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE Strict #-} +module Picture.Render + where +import Control.Lens +import Picture +import Geometry + +import Picture.Preload +--import Control.Lens + +import Foreign + +import Codec.Picture + +import Graphics.Rendering.OpenGL hiding (translate,scale,imageHeight,imageWidth) +import qualified Graphics.Rendering.OpenGL as GL + +import Data.Foldable +import qualified Data.Vector.Storable as V +import qualified Data.DList as DL + +import Control.DeepSeq + +concat34 :: (Point3,RGBA) -> [Float] +concat34 ((x,y,z),(r,g,b,a)) = [x,y,z,r,g,b,a] + + +toVec2 (x,y) = Vector2 x y +toVec3 (x,y,z) = Vector3 x y z +toVec4 (x,y,z,w) = Vector4 x y z w + +flat2 (x,y) = DL.fromList [x,y] +flat3 (x,y,z) = DL.fromList [x,y,z] +flat4 (x,y,z,w) = DL.fromList [x,y,z,w] + +mapFlat :: (NFData b) => (a -> DL.DList b) -> DL.DList a -> [b] +mapFlat f = force . DL.toList . foldMap f + +--marshallVs = V.unsafeWith . V.fromList +--marshallVs = withArray + +renderPicture' :: PreloadData -> Picture -> IO () +renderPicture' pdata (Scene posTri' colTri' posChar' colChar' texChar') = do + let posTri = DL.toList posTri' + colTri = DL.toList colTri' + posChar = DL.toList posChar' + colChar = DL.toList colChar' + texChar = DL.toList texChar' + currentProgram $= Just (_basicShader pdata) + bindVertexArrayObject $= Just (_basicVAO pdata) + bindBuffer ArrayBuffer $= Just (_posVBO pdata) + let firstIndex = 0 + let vertices :: [Float] + vertices = mapFlat flat3 posTri' + numVertices = length vertices + vertexSize = sizeOf (head vertices) + pokeArray (_ptrPosVBO pdata) vertices + bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), _ptrPosVBO pdata, StreamDraw) +-- marshallVs vertices $ \ptr -> do +-- bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw) + bindBuffer ArrayBuffer $= Just (_colVBO pdata) + let colVs = mapFlat flat4 colTri' + colVsize = sizeOf $ head colVs + pokeArray (_ptrColVBO pdata) colVs + bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), _ptrColVBO pdata, StreamDraw) +-- marshallVs colVs $ \ptr -> do +-- bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), ptr, StreamDraw) + drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices) + +-- currentProgram $= Just (_textShader pdata) +-- bindVertexArrayObject $= Just (_textVAO pdata) +-- bindBuffer ArrayBuffer $= Just (_posVBO pdata) +-- let vertices' = mapFlat flat3 posChar' +-- numVertices' = length vertices' +-- vertexSize' = sizeOf $ head vertices' +-- withArray vertices' $ \ptr -> do +-- bufferData ArrayBuffer $= (fromIntegral (numVertices' * vertexSize'), ptr, StreamDraw) +-- bindBuffer ArrayBuffer $= Just (_colVBO pdata) +-- let colVsT = mapFlat flat4 colChar' +-- colVsTsize = sizeOf $ head colVsT +-- withArrayLen colVsT $ \numV' ptr -> do +-- bufferData ArrayBuffer $= (fromIntegral (numVertices' * colVsTsize), ptr, StreamDraw) +-- bindBuffer ArrayBuffer $= Just (_texVBO pdata) +-- let texVsT = mapFlat flat2 texChar' +-- texVsTsize = sizeOf $ head texVsT +-- withArrayLen texVsT $ \numV' ptr -> do +-- bufferData ArrayBuffer $= (fromIntegral (numVertices' * texVsTsize), ptr, StreamDraw) +-- drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices') + + + +bufferOffset :: Integral a => a -> Ptr b +bufferOffset = plusPtr nullPtr . fromIntegral + +zeroZ :: Point2 -> Point3 +zeroZ (x,y) = (x,y,0) diff --git a/src/Render.hs b/src/Render.hs new file mode 100644 index 000000000..5372b97bb --- /dev/null +++ b/src/Render.hs @@ -0,0 +1,108 @@ +module Render where +import Shapes +import Graphics.Rendering.OpenGL hiding (imageHeight,imageWidth) +import Foreign +import Loop +import Codec.Picture +import qualified Data.Vector.Storable as V + + +render :: [Program] -> b -> Shape -> IO () +render progs _ (Shape primitiveMode vs) = do + currentProgram $= Just (progs !! 0) + let vertices = flattenVertices vs + numVertices = length vertices + vertexSize = sizeOf (head vertices) + + -- setup VBO + shape <- genObjectName + bindVertexArrayObject $= Just shape + + -- setup VBA + arrayBuffer <- genObjectName + bindBuffer ArrayBuffer $= Just arrayBuffer + withArray vertices $ \ptr -> do + bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StaticDraw) + + let firstIndex = 0 + vPosition = AttribLocation 0 + vColor = AttribLocation 1 + vertexAttribPointer vPosition $= + ( ToFloat + , VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 7) + (bufferOffset (firstIndex * vertexSize)) + ) + vertexAttribArray vPosition $= Enabled + + vertexAttribPointer vColor $= + ( ToFloat + , VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 7) + (bufferOffset ((firstIndex + 3) * vertexSize) ) + ) + vertexAttribArray vColor $= Enabled + +-- clear [ColorBuffer,DepthBuffer] + + bindVertexArrayObject $= Just shape + drawArrays primitiveMode (fromIntegral firstIndex) (fromIntegral $ div numVertices 2) + + +render (_:prog:_) _ (Fade ps) = do + currentProgram $= Just prog + let vertices = flatten2 ps + numVertices = length vertices + vertexSize = sizeOf (head vertices) + +-- -- setup uniform +-- location <- get $ uniformLocation prog "winSize" +-- uniform location $= winSizeVec + + -- setup VBO + arrayBuffer <- genObjectName + bindBuffer ArrayBuffer $= Just arrayBuffer + withArray vertices $ \ptr -> do + bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw) + + -- setup VAO + shape <- genObjectName + bindVertexArrayObject $= Just shape + + let firstIndex = 0 + inPosition = AttribLocation 0 + inColor = AttribLocation 1 + inRad = AttribLocation 2 + vertexAttribPointer inPosition $= + ( ToFloat + , VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 8) + (bufferOffset (firstIndex * vertexSize)) + ) + vertexAttribArray inPosition $= Enabled + + vertexAttribPointer inColor $= + ( ToFloat + , VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 8) + (bufferOffset ((firstIndex + 3) * vertexSize) ) + ) + vertexAttribArray inColor $= Enabled + + vertexAttribPointer inRad $= + ( ToFloat + , VertexArrayDescriptor 1 Float (fromIntegral $ vertexSize * 8) + (bufferOffset ((firstIndex + 7) * vertexSize) ) + ) + vertexAttribArray inRad $= Enabled + +-- bindVertexArrayObject $= Just shape + drawArrays Points (fromIntegral firstIndex) (2) + + +flattenVertices :: [CPoint] -> [GLfloat] +flattenVertices = map realToFrac . concatMap (\(CPoint (x,y,z) (r,b,g,a)) -> [x,y,z,r,b,g,a]) + +flatten2 :: [((Float,Float,Float),(Float,Float,Float,Float),Float)] -> [GLfloat] +flatten2 = map realToFrac . concatMap f + where f ((x,y,z),(r,g,b,a),rad) = [x,y,z,r,g,b,a,rad] + +bufferOffset :: Integral a => a -> Ptr b +bufferOffset = plusPtr nullPtr . fromIntegral + diff --git a/src/Rendering/Picture/Color.hs b/src/Rendering/Picture/Color.hs new file mode 100644 index 000000000..8fc354554 --- /dev/null +++ b/src/Rendering/Picture/Color.hs @@ -0,0 +1,21 @@ +module Rendering.Picture.Color + where +import Geometry.Data + +type RGBA = (Float,Float,Float,Float) + +black,red,green,blue,yellow,cyan,magenta,rose,violet,azure,aquamarine,chartreuse,orange,white::RGBA +black = (0,0,0,1) +red = (1,0,0,1) +green = (0,1,0,1) +blue = (0,0,1,1) +yellow = (1,1,0,1) +cyan = (0,1,1,1) +magenta = (1,0,1,1) +rose = (1,0,0.5,1) +violet = (0.5,0,1,1) +azure = (0,0.5,1,1) +aquamarine= (0,1,0.5,1) +chartreuse= (0.5,1,0,1) +orange = (1,0.5,0,1) +white = (1,1,1,1) diff --git a/src/Shaders.hs b/src/Shaders.hs new file mode 100644 index 000000000..78e76669d --- /dev/null +++ b/src/Shaders.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE QuasiQuotes #-} +module Shaders + (setupBasicShader + ,setupFadeShader + ,setupShaders + ,makeTextureShader + ,makeBasicShader + ,makeFadeShader + ) + where +import Graphics.Rendering.OpenGL +import Control.Monad (when) +import Text.RawString.QQ +import qualified Data.ByteString as BS + +setupShaders :: IO [Program] +setupShaders = do + basicShader <- makeBasicShader + fadeShader <- makeFadeShader + textureShader <- makeTextureShader + return [basicShader,fadeShader,textureShader] + +makeBasicShader :: IO Program +makeBasicShader = do + vsSource <- BS.readFile "shader/basic.vert" + fsSource <- BS.readFile "shader/basic.frag" + + makeShaderProgram [(VertexShader, vsSource) + ,(FragmentShader, fsSource) + ] + +setupBasicShader :: IO () +setupBasicShader = do + shaderProgram <- makeBasicShader + currentProgram $= (Just shaderProgram) + +makeFadeShader :: IO Program +makeFadeShader = do + vsSource <- BS.readFile "shader/fadeCircle.vert" + gsSource <- BS.readFile "shader/fadeCircle.geom" + fsSource <- BS.readFile "shader/fadeCircle.frag" + + makeShaderProgram [(VertexShader, vsSource ) + ,(GeometryShader, gsSource ) + ,(FragmentShader, fsSource ) + ] + +setupFadeShader :: IO Program +setupFadeShader = do + shaderProgram <- makeFadeShader + currentProgram $= (Just shaderProgram) + return shaderProgram + +makeTextureShader :: IO Program +makeTextureShader = do + vsSource <- BS.readFile "shader/basicTexture.vert" + fsSource <- BS.readFile "shader/basicTexture.frag" + + makeShaderProgram [(VertexShader, vsSource ) + ,(FragmentShader, fsSource ) + ] + +makeShaderProgram :: [(ShaderType,BS.ByteString)] -> IO Program +makeShaderProgram sources = do + shaderProgram <- createProgram + shaders <- mapM compileAndCheckShader sources + mapM_ (attachShader shaderProgram) shaders + + linkProgram shaderProgram + linkingSuccess <- linkStatus shaderProgram + when (not linkingSuccess) $ do + infoLog <- get (programInfoLog shaderProgram) + putStrLn $ "Program Linking" ++ infoLog + + return shaderProgram + +compileAndCheckShader :: (ShaderType,BS.ByteString) -> IO Shader +compileAndCheckShader (shaderType,sourceCode) = do + theShader <- createShader shaderType + shaderSourceBS theShader $= sourceCode + compileShader theShader + success <- compileStatus theShader + when (not success) $ do + infoLog <- get (shaderInfoLog theShader) + putStrLn $ "Shader compile: " ++ show shaderType ++ " : " ++ show infoLog + return theShader diff --git a/src/Shapes.hs b/src/Shapes.hs new file mode 100644 index 000000000..64317f928 --- /dev/null +++ b/src/Shapes.hs @@ -0,0 +1,28 @@ +module Shapes where +import Geometry +import Graphics.Rendering.OpenGL + +type RGBA = (Float,Float,Float,Float) + +data CPoint = CPoint + {cpPoint :: Point3 + ,cpColor :: RGBA + } + +data Shape = Shape PrimitiveMode [CPoint] + | Fade [(Point3,RGBA,Float)] + | Shape' PrimitiveMode [GLfloat] + +egTri = Shape TriangleStrip [CPoint (-1,0,0) (1,1,1,1) + ,CPoint (0,1,0) (1,1,0,1) + ,CPoint (1,0,0) (1,0,1,0) + ,CPoint (0.5,-0.5,0) (1,0,1,0) + ,CPoint (0.5,-0.5,0) (1,0,1,0) + ,CPoint (0.5,-0.5,0) (1,0,1,0) + ] + +egFade = Fade [((-0.2,-0.2,0),(1,1,1,1),500) + ,((0.2,0.2,0),(1,1,1,1),500) +-- ,((0.5,0.5,0),(1,1,1,1),0.5) +-- ,((0.5,0.5,0),(1,1,1,1),0.5) + ]