Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • 9562850/fp-asteroids
1 result
Show changes
Commits on Source (4)
Hide whitespace changes
Inline Side-by-side
src/Controller.hs
View file @ 52e4b316
......@@ -34,7 +34,6 @@ input :: Event -> GameState -> IO GameState
input e gstate@(GameState {screen = Game}) = return (inputKey e gstate)
input e gstate@(GameState {screen = MainMenu}) = return (inputMM e gstate)
input e gstate@(GameState {screen = ChangeName}) = return (inputCN e gstate)
input e gstate@(GameState {screen = Settings}) = return (inputST e gstate)
input e gstate@(GameState {screen = Pause}) = return (inputPS e gstate)
input e gstate@(GameState {screen = Death}) = return (inputDS e gstate)
......@@ -43,7 +42,6 @@ input e gstate@(GameState {screen = Death}) = return (inputDS e gstate)
inputMM :: Event -> GameState -> GameState
inputMM (EventKey (MouseButton LeftButton) _ _ (x,y)) gstate
| collidesWith 50 (x,y) (0,0) = gstate {screen = Game}
| (x,y) `inBox` controlsBox = gstate {screen = Settings}
| otherwise = gstate
inputMM (EventKey (SpecialKey KeyEnter) Down _ _) gstate = gstate {screen = ChangeName, player = removeDefault $ player gstate }
inputMM _ gstate = gstate
......@@ -73,27 +71,19 @@ addDefault player@(Player {name = ""}) = player {name = "Player"}
addDefault s = s
-- SETTINGS SECTION :
inputST :: Event -> GameState -> GameState
inputST _ gstate = gstate
-- PAUSE SECTION :
inputPS :: Event -> GameState -> GameState
inputPS (EventKey (SpecialKey KeyCtrlL) Down _ _) gstate = gstate {screen = Game}
inputPS _ gstate = gstate
inputPS (EventKey (SpecialKey KeyCtrlL) Down _ _) = toggleGamePaused
inputPS _ = id
-- DEATH SCREEN SECTION :
inputDS :: Event -> GameState -> GameState
inputDS (EventKey (SpecialKey KeyEnter) Down _ _) gstate = (initialState $ seed gstate) {highscores = highscores gstate, player = (player gstate) { lives = 3, score = 0}}
inputDS _ gstate = gstate
inputDS (EventKey (SpecialKey KeyEnter) Down _ _) = exitGame
inputDS _ = id
......@@ -176,11 +166,24 @@ newGen :: StdGen -> StdGen
newGen gen = snd $ split gen
inputKey :: Event -> GameState -> GameState
inputKey (EventKey (SpecialKey KeyEsc) _ _ _) gstate = (initialState (seed gstate)) { player = (player gstate) { lives = 3, score = 0}, highscores = highscores gstate }
inputKey (EventKey (SpecialKey KeyCtrlL) Down _ _) gstate = gstate { screen = Pause, keys = []}
inputKey (EventKey key Down _ _) gstate = gstate { keys = insert key $ keys gstate}
inputKey (EventKey key Up _ _) gstate = gstate { keys = delete key $ keys gstate}
inputKey _ gstate = gstate -- Otherwise keep the same
inputKey (EventKey (SpecialKey KeyEsc) Down _ _) = exitGame
inputKey (EventKey (SpecialKey KeyCtrlL) Down _ _) = toggleGamePaused
inputKey (EventKey key Down _ _) = insertKey key
inputKey (EventKey key Up _ _) = deleteKey key
inputKey _ = id -- Otherwise keep the same
insertKey :: Key -> GameState -> GameState
insertKey key gstate = gstate { keys = insert key $ keys gstate }
deleteKey :: Key -> GameState -> GameState
deleteKey key gstate = gstate { keys = delete key $ keys gstate }
toggleGamePaused :: GameState -> GameState
toggleGamePaused gstate@(GameState {screen = Pause}) = gstate { screen = Game }
toggleGamePaused gstate = gstate { screen = Pause, keys = [] }
exitGame :: GameState -> GameState
exitGame gstate = (initialState (seed gstate)) { player = (player gstate) { lives = 3, score = 0 }, highscores = highscores gstate }
applyKeys :: GameState -> GameState
applyKeys gstate@(GameState {controls, keys, elapsedTime}) = foldl applyKey gstate keys
......@@ -220,16 +223,19 @@ enemySpawnDelay = 2
meteorSpawnChance :: Float
meteorSpawnChance = 0.8
maxNumOfUfos :: Int
maxNumOfUfos = 3
tickMeteors :: Float -> GameState -> GameState
tickMeteors secs gstate@(GameState{meteorTimer, elapsedTime, seed, ufos})
| meteorTimer > enemySpawnDelay = do
let (prob, _) = randomR (0, 1 :: Float) seed
if prob <= meteorSpawnChance
let (prob, seed') = randomR (0, 1 :: Float) seed
if prob <= meteorSpawnChance || length ufos >= maxNumOfUfos
then do
let (newMeteor, newGen) = spawn seed
let (newMeteor, newGen) = spawn seed'
gstate { ufos = map (updateUFO gstate secs) ufos, meteors = map (move secs) $ newMeteor : (meteors gstate), seed = newGen, meteorTimer = 0}
else do
let (newUfo, newGen) = spawn seed
let (newUfo, newGen) = spawn seed'
gstate { ufos = map (updateUFO gstate secs) $ newUfo { lastMove = elapsedTime + 5 } : ufos, meteors = map (move secs) $ meteors gstate, meteorTimer = -2, seed = newGen}
| otherwise = gstate { ufos = map (moveShooter secs) $ ufos, meteors = map (move secs) $ meteors gstate}
......@@ -246,11 +252,11 @@ updateUFO gstate@(GameState{elapsedTime, spaceShip}) secs ufo =
let ufo' = ufo {lastMove = elapsedTime}
let (index, newGen) = randomR (fromEnum (minBound :: UFOMove), fromEnum (maxBound :: UFOMove)) $ gen' ufo
case (toEnum index :: UFOMove) of
Approach -> moveShooter secs ufo' {gen' = newGen, ufoObj = (ufoObj ufo) { velocity = 50, orientation = aimUFOtoSpaceship ufo' spaceShip } }
Approach -> moveShooter secs ufo' {gen' = newGen, ufoObj = (ufoObj ufo) { velocity = 50, orientation = aimUFOtoSpaceship ufo' spaceShip } }
StrafeLeft -> moveShooter secs ufo' {gen' = newGen, ufoObj = (ufoObj ufo) { velocity = 50, orientation = 0.5 * pi + aimUFOtoSpaceship ufo' spaceShip}}
StrafeRight -> moveShooter secs ufo' {gen' = newGen, ufoObj = (ufoObj ufo) { velocity = 50, orientation = -0.5 * pi + aimUFOtoSpaceship ufo' spaceShip}}
Attack -> moveShooter secs $ shoot ufo' {gen' = newGen, ufoObj = (ufoObj ufo) {orientation = aimUFOtoSpaceship ufo' spaceShip}}
Idle -> moveShooter secs ufo' { gen' = newGen}
Attack -> moveShooter secs $ shoot ufo' {gen' = newGen, ufoObj = (ufoObj ufo) {orientation = aimUFOtoSpaceship ufo' spaceShip}}
Idle -> moveShooter secs ufo' { gen' = newGen}
else moveShooter secs ufo
aimUFOtoSpaceship :: UFO -> Spaceship -> Orientation
......@@ -325,9 +331,6 @@ collidesWith margin (x1, y1) (x2, y2) =
inBox :: Location -> Box -> Bool
inBox (x,y) (Box maxX minX maxY minY) = maxX > x && x > minX && maxY > y && y > minY
accelerateSpaceShip :: Spaceship -> Spaceship
accelerateSpaceShip spaceship@(Spaceship {shipObj, specs}) = spaceship { shipObj = shipObj { velocity = (getVelocity spaceship + speed specs) } }
tryShoot :: Float -> Spaceship -> Spaceship
tryShoot currentTime spaceship@(Spaceship {lastShot, specs})
| lastShot + (1 / fireRate specs) < currentTime = shoot spaceship {lastShot = currentTime}
......
src/Model.hs
View file @ 52e4b316
......@@ -62,8 +62,6 @@ instance Moving Bullet where
setVelocity v bullet = bullet { bulletObj = setVelocity v $ bulletObj bullet}
getFriction _ = 0
instance Displayable Bullet where
data Specifications = Specs {
speed :: Float
, maneuverability :: Float
......@@ -88,6 +86,9 @@ instance Moving Spaceship where
setVelocity v spaceship = spaceship {shipObj = setVelocity v $ shipObj spaceship}
getFriction _ = 1
accelerateSpaceShip :: Spaceship -> Spaceship
accelerateSpaceShip spaceship@(Spaceship {shipObj, specs}) = spaceship { shipObj = shipObj { velocity = (getVelocity spaceship + speed specs) } }
instance Shooting Spaceship where
getBullets = bullets
setBullets bul spaceship = spaceship { bullets = bul }
......@@ -95,8 +96,6 @@ instance Shooting Spaceship where
setSeed newGen spaceship = spaceship { gen = newGen}
getAccuracy = accuracy . specs
instance Displayable Spaceship where
type Size = Int
data Meteor = Meteor { meteorObj :: MovingObject, size :: Size}
......@@ -113,8 +112,6 @@ instance Spawnable Meteor where
defaultObj = (Meteor (MovingObject (0,0) 0 0) 1)
setSize size meteor = meteor { size = size }
instance Displayable Meteor where
data UFO = UFO {
ufoObj :: MovingObject
, bulletss :: [Bullet]
......@@ -140,41 +137,6 @@ instance Shooting UFO where
setSeed newGen ufo = ufo { gen' = newGen }
getAccuracy _ = 90
instance Displayable UFO where
toImage = drawUFO
where
-- temporary reused code from meteor
makeUFO :: UFO -> (Point, Point, Point, Point, Point, Point)
makeUFO (UFO movingObject@(MovingObject {location, orientation}) _ _ _) = makeHexagon 20 location orientation
makeHexagon :: Float -> Location -> Orientation -> (Point, Point, Point, Point, Point, Point)
makeHexagon o (locx, locy) angle = do
let gen = mkStdGen 2024
let angley = fst (randomR (negate locy - 200, negate locy + 200) gen) / 100
let anglex = negate locx / 100
let translate (x, y) = (x + anglex, y + angley)
let (x1, y1) = ( locx - o, locy) --left corner
let (x2, y2) = ( locx - (o/2), locy + o) --left top corner
let (x3, y3) = ( locx + (o/2), locy + o) --right top corner
let (x4, y4) = ( locx + o, locy) --right corner
let (x5, y5) = ( locx + (o/2), locy - o) --right bottom corner
let (x6, y6) = ( locx - (o/2), locy - o) --left bottom corner
let (x1', y1') = translate (x1, y1)
let (x2', y2') = translate (x2, y2)
let (x3', y3') = translate (x3, y3)
let (x4', y4') = translate (x4, y4)
let (x5', y5') = translate (x5, y5)
let (x6', y6') = translate (x6, y6)
((x1', y1'), (x2', y2'), (x3', y3'), (x4', y4'), (x5', y5'), (x6', y6'))
drawUFO :: UFO -> Picture
drawUFO ufo = color red (polygon [a,b,c,d,e,f])
where
(a,b,c,d,e,f) = makeUFO ufo
instance Spawnable UFO where
defaultObj = (UFO (MovingObject (0,0) 0 0) [] (mkStdGen 2024) 0)
setSize _ = id
......@@ -187,16 +149,6 @@ nextFrame (Explosion l i) = (Explosion l $ i+1)
isOutdated :: Explosion -> Bool
isOutdated (Explosion _ i) = i > 60
instance Displayable Explosion where
toImage (Explosion loc frame) = case frame of
_ | frame < 20 -> color white $ circlePlus' loc 15
| frame < 40 -> color white $ circlePlus' loc 10
| frame < 60 -> color white $ circlePlus' loc 5
| otherwise -> blank
where
circlePlus' :: Point -> Float -> Picture
circlePlus' (x, y) radius = translate x y (circleSolid radius)
type Score = Int
type Name = String
type Lives = Int
......@@ -204,14 +156,25 @@ data Player = Player { lives :: Lives, score :: Score, name :: Name }
type Highscore = (Name, Score)
isNewHighscore :: GameState -> Bool
isNewHighscore gstate@(GameState {highscores, player}) = do
let newScore = score player
let topScore = snd $ head $ tail highscores
newScore > topScore
data Box = Box { maxX :: Float, minX :: Float, maxY :: Float, minY :: Float }
data Effect = Speed | Maneuverability | Accuracy | FireRate deriving (Show, Enum, Bounded)
data Powerup = Powerup { position :: Location, effect :: Effect } deriving (Show)
instance Displayable Powerup where
effectColor :: Effect -> Color
effectColor Speed = blue
effectColor Maneuverability = green
effectColor Accuracy = red
effectColor FireRate = orange
data Powerup = Powerup { position :: Location, effect :: Effect } deriving (Show)
data Screen = MainMenu | Pause | ChangeName | Settings | Game | Death
data Screen = MainMenu | Pause | ChangeName | Game | Death
data Controls = Controls {
accelerate :: Key
......
src/View.hs
View file @ 52e4b316
......@@ -25,7 +25,7 @@ viewPure gstate@(GameState {screen, ufos, meteorTimer, spaceShip, player, poweru
, color (greyN 0.7) (textPlus (-106, -190) 0.2 $ " W | Accelerate")
, color (greyN 0.7) (textPlus (-100, -220) 0.2 $ "<-- | Rotate left")
, color (greyN 0.7) (textPlus (-100, -250) 0.2 $ "--> | Rotate right")
, color (greyN 0.7) (textPlus (-100, -280) 0.2 $ " X | Shoot")
, color (greyN 0.7) (textPlus (-97, -280) 0.2 $ "Click | Shoot")
, color (greyN 0.7) (textPlus (-92, -310) 0.2 $ "ESC | Back to Main Menu")
, color (greyN 0.7) (textPlus (-106, -340) 0.2 $ "CTRL | Pause Game")
]
......@@ -37,9 +37,6 @@ viewPure gstate@(GameState {screen, ufos, meteorTimer, spaceShip, player, poweru
let playerName = color yellow (textPlus (0, 80) 0.3 $ show (name player))
let confirm = color red (textPlus (0, 150) 0.2 $ "Press enter to confirm")
pictures (title:confirm:[playerName])
Settings -> do
let title = color white (textPlus (-500, 250) 0.5 "Settings")
pictures (title:[])
Pause -> do
let title = color white (textPlus (-400, 250) 0.5 "Paused")
info = color yellow (textPlus (-400, 100) 0.3 "Press Control to continue")
......@@ -57,11 +54,6 @@ viewPure gstate@(GameState {screen, ufos, meteorTimer, spaceShip, player, poweru
]
pictures(newHighScore:title:footer:stats)
Game -> do
let ship = color green (polygon [a,b,c])
let bullets' = pictures $ map (color yellow . polygon . makeBullet 5) (bullets spaceShip)
let bulletss' = pictures $ map (pictures . map (color yellow . polygon . makeBullet 5)) (map bulletss ufos)
let powerup' = makePowerup powerup
let textSize = 0.2
let (textX, textY) = (-600, 300)
let player' = color white (textPlus (textX, textY) textSize $ show (name player) ++ " " ++ (replicate (lives player) '*'))
......@@ -73,15 +65,65 @@ viewPure gstate@(GameState {screen, ufos, meteorTimer, spaceShip, player, poweru
let tooltip' = color (greyN 0.5) (textPlus (-50, textY - 30) (textSize-0.06) $ tooltip)
let ufos' = pictures (map toImage ufos)
let bulletss' = pictures $ map (pictures . map toImage) (map bulletss ufos)
let meteors' = pictures (map drawMeteor (meteors gstate))
let ship' = toImage spaceShip
let bullets' = pictures $ map toImage (bullets spaceShip)
let powerup' = maybeMake powerup
let meteors' = pictures (map toImage $ meteors gstate)
let explos' = pictures (map toImage $ explosions gstate)
let pics = [debug, player', explos', ufos', meteors', score', tooltip', notif, powerup', time, velocity', ship, bullets', bulletss']
let pics = [debug, player', explos', ufos', meteors', score', tooltip', notif, powerup', time, velocity', ship', bullets', bulletss']
pictures pics
maybeMake :: Maybe Powerup -> Picture
maybeMake Nothing = blank
maybeMake (Just x) = toImage x
instance Displayable Powerup where
toImage (Powerup (x,y) eff) = color (effectColor eff) (circlePlus (x, y) 15)
instance Displayable Spaceship where
toImage spaceship = let (a,b,c) = makeTriangle 30 (getLocation spaceship) (getOrientation spaceship)
in color green (polygon [a,b,c])
instance Displayable UFO where
toImage = drawUFO
where
makeUFO :: UFO -> (Point, Point, Point, Point, Point, Point)
makeUFO (UFO movingObject@(MovingObject {location, orientation}) _ _ _) = makeHexagon 20 location orientation
drawUFO :: UFO -> Picture
drawUFO ufo = color red (polygon [a,b,c,d,e,f])
where
(a,b,c,d,e,f) = makeUFO ufo
instance Displayable Meteor where
toImage meteor = color white (polygon [a,b,c,d,e,f])
where
(a,b,c,d,e,f) = makeMeteor meteor
makeMeteor :: Meteor -> (Point, Point, Point, Point, Point, Point)
makeMeteor meteor@(Meteor {size = 1}) = makeHexagon 20 (getLocation meteor) (getOrientation meteor)
makeMeteor meteor@(Meteor {size = 2}) = makeHexagon 40 (getLocation meteor) (getOrientation meteor)
makeMeteor meteor@(Meteor {size = 3}) = makeHexagon 60 (getLocation meteor) (getOrientation meteor)
instance Displayable Bullet where
toImage bullet = do
let (a,b,c) = makeTriangle 5 (getLocation bullet) (getOrientation bullet)
color yellow $ polygon $ [a,b,c]
instance Displayable Explosion where
toImage (Explosion loc frame) = case frame of
_ | frame < 20 -> color white $ circlePlus' loc 15
| frame < 40 -> color white $ circlePlus' loc 10
| frame < 60 -> color white $ circlePlus' loc 5
| otherwise -> blank
where
(a,b,c) = makeSpaceship spaceShip 30
circlePlus' :: Point -> Float -> Picture
circlePlus' (x, y) radius = translate x y (circleSolid radius)
textPlus :: Point -> Float -> String -> Picture
textPlus (x, y) size string = translate x y $ scale size size (text string)
......@@ -89,43 +131,9 @@ textPlus (x, y) size string = translate x y $ scale size size (text string)
circlePlus :: Point -> Float -> Picture
circlePlus (x, y) radius = translate x y (circle radius)
isNewHighscore :: GameState -> Bool
isNewHighscore gstate@(GameState {highscores, player}) = do
let newScore = score player
let topScore = snd $ head $ tail highscores
newScore > topScore
makeHighScore :: (Int, Picture) -> Highscore -> (Int, Picture)
makeHighScore (y, picture) (name, score) = (y-30, pictures [picture, textPlus(-500, fromIntegral y) 0.2 $ show name ++ ": " ++ show score])
makePowerup :: Maybe Powerup -> Picture
makePowerup Nothing = blank
makePowerup (Just (Powerup (x,y) eff)) = color (effectColor eff) (circlePlus (x, y) 15)
where
effectColor :: Effect -> Color
effectColor Speed = blue
effectColor Maneuverability = green
effectColor Accuracy = red
effectColor FireRate = orange
makeSpaceship :: Spaceship -> Float -> (Point, Point, Point)
makeSpaceship spaceship o = makeTriangle o (getLocation spaceship) (getOrientation spaceship)
makeBullet :: Float -> Bullet -> [Point]
makeBullet o bullet = do
let (a,b,c) = makeTriangle o (getLocation bullet) (getOrientation bullet)
[a,b,c]
makeMeteor :: Meteor -> (Point, Point, Point, Point, Point, Point)
makeMeteor meteor@(Meteor {size = 1}) = makeHexagon 20 (getLocation meteor) (getOrientation meteor)
makeMeteor meteor@(Meteor {size = 2}) = makeHexagon 40 (getLocation meteor) (getOrientation meteor)
makeMeteor meteor@(Meteor {size = 3}) = makeHexagon 60 (getLocation meteor) (getOrientation meteor)
drawMeteor :: Meteor -> Picture
drawMeteor meteor = color white (polygon [a,b,c,d,e,f])
where
(a,b,c,d,e,f) = makeMeteor meteor
-- Creates the 3 points of a triangle which are centered on a Location,
-- The triangle is oriented in a certain way and always has the same size (o)
makeTriangle :: Float -> Location -> Orientation -> (Point, Point, Point)
......