Skip to content

Instantly share code, notes, and snippets.

@patrickt
Created October 5, 2020 15:54
Show Gist options
  • Save patrickt/534b9e858c449e02154b6f0bcc8feb15 to your computer and use it in GitHub Desktop.
Save patrickt/534b9e858c449e02154b6f0bcc8feb15 to your computer and use it in GitHub Desktop.
diff --git a/PLAN.org b/PLAN.org
index a79dafc..df34532 100644
--- a/PLAN.org
+++ b/PLAN.org
@@ -30,5 +30,6 @@ So how are we gonna do messages, too? Presumably there should be a status bar on
sidebar, +status bar, and body+
generalize the (Reader (BChan x)) and (Reader (MVar x)) and whatever with some unified Pipe interface
+prevent crashes by implementing valid, occupied :: Position -> Canvas -> Bool
slurp in some enemies
multi-square things? z-levels in the canvas? gonna need them
diff --git a/cabal.project b/cabal.project
deleted file mode 100644
index e6fdbad..0000000
--- a/cabal.project
+++ /dev/null
@@ -1 +0,0 @@
-packages: .
diff --git a/possession.cabal b/possession.cabal
index fe6cc98..36248a3 100644
--- a/possession.cabal
+++ b/possession.cabal
@@ -37,7 +37,6 @@ library
base ^>=4.14.1.0
exposed-modules:
Possession
- Data.Position
Game.Action
Game.Canvas
Game.Command
diff --git a/src/Data/Position.hs b/src/Data/Position.hs
deleted file mode 100644
index aaf3747..0000000
--- a/src/Data/Position.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-module Data.Position
- ( Position (..)
- , V2 (..)
- , make
- , offset
- ) where
-
-import Data.Ix
-import Linear.V2
-
-newtype Position = Position (V2 Int)
- deriving stock (Eq, Ord, Show)
- deriving newtype (Ix, Num)
-
-make :: Int -> Int -> Position
-make x y = Position (V2 x y)
-
-offset :: V2 Int -> Position -> Position
-offset v (Position p) = Position (v + p)
diff --git a/src/Game/Canvas.hs b/src/Game/Canvas.hs
index d441630..983f910 100644
--- a/src/Game/Canvas.hs
+++ b/src/Game/Canvas.hs
@@ -6,9 +6,9 @@
module Game.Canvas where
import Data.Array (Array, array, (!), (//))
-import Data.Position (Position)
-import Data.Position qualified as Position
-import Game.World (Color (..), Glyph (..))
+import Game.World (Color (..), Glyph (..), Position (..))
+import Game.World qualified as Position
+import Linear
data Sprite = Sprite
{ glyph :: !Glyph,
@@ -23,17 +23,15 @@ size :: Int
size = 16
bounds :: (Position, Position)
-bounds = (0 :: Position, Position.make size size)
+bounds = (0 :: Position, Position (V2 size size))
borders :: [Position]
borders = up <> down <> left <> right
where
- up = Position.make <$> horizontal <*> pure 0
- down = Position.make <$> horizontal <*> pure size
- left = Position.make 0 <$> vertical
- right = Position.make size <$> vertical
- horizontal = [0..size]
- vertical = [1..size-1]
+ up = Position.make <$> [0..size] <*> pure 0
+ down = Position.make <$> [0..size] <*> pure (size)
+ left = Position.make 0 <$> [1..(size-1)]
+ right = Position.make (size-1) <$> [1..(size-1)]
newtype Canvas = Canvas {unCanvas :: Array Position Sprite}
deriving newtype (Show)
@@ -42,7 +40,7 @@ empty :: Canvas
empty = Canvas $ array bounds do
x <- [0 .. size]
y <- [0 .. size]
- pure (Position.make x y, blankSprite)
+ pure (Position (V2 x y), blankSprite)
update :: Canvas -> [(Position, Sprite)] -> Canvas
update (Canvas arr) assocs = Canvas (arr // assocs)
diff --git a/src/Game/Ecs.hs b/src/Game/Ecs.hs
index ba3ae7c..694c3f4 100644
--- a/src/Game/Ecs.hs
+++ b/src/Game/Ecs.hs
@@ -2,7 +2,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@@ -19,11 +18,10 @@ import Control.Concurrent
import Control.Effect.Optics
import Control.Monad
import Control.Monad.IO.Class
+import Data.Generics.Product
import Data.Foldable (for_)
import Data.Maybe (isJust)
import Data.Monoid
-import Data.Position (Position (..))
-import Data.Position qualified as Position
import Game.Action
import Game.Canvas qualified as Canvas
import Game.Canvas qualified as Game (Canvas)
@@ -33,8 +31,6 @@ import Game.World qualified as World
import Linear (V2 (..))
import Relude.Bool.Guard
-type GameState = Game.State.State
-
draw :: (Eff.Has Trace sig m, MonadIO m) => Apecs.SystemT Game.World m Game.Canvas
draw = do
trace "Run::draw"
@@ -42,7 +38,7 @@ draw = do
trace (show new)
pure (Canvas.empty `Canvas.update` new)
where
- go :: [(Position, Canvas.Sprite)] -> (Position, World.Glyph, World.Color) -> [(Position, Canvas.Sprite)]
+ go :: [(World.Position, Canvas.Sprite)] -> (World.Position, World.Glyph, World.Color) -> [(World.Position, Canvas.Sprite)]
go acc (pos, chr, color) = (pos, Canvas.Sprite chr color) : acc
loop ::
@@ -59,7 +55,7 @@ loop = do
case next of
Move dir -> do
- prospective <- Position.offset dir <$> playerPosition
+ prospective <- (World.Position dir +) <$> playerPosition
unlessM (occupied prospective) $
movePlayer dir
NoOp -> pure ()
@@ -72,38 +68,38 @@ loop = do
pure ()
movePlayer :: MonadIO m => V2 Int -> Apecs.SystemT Game.World m ()
-movePlayer dx = Apecs.cmap \(Position p, World.Player) -> Position (dx + p)
+movePlayer dx = Apecs.cmap \(World.Position p, World.Player) -> World.Position (dx + p)
-playerPosition :: (Eff.Has (State GameState) sig m, MonadIO m) => Apecs.SystemT Game.World m Position
+playerPosition :: (Eff.Has (State Game.State.State) sig m, MonadIO m) => Apecs.SystemT Game.World m World.Position
playerPosition = do
- (World.Player, loc) <- Apecs.get =<< use @GameState#player
+ p <- use (field @"player" @Game.State.State)
+ (World.Player, loc) <- Apecs.get p
pure loc
-occupied :: MonadIO m => Position -> Apecs.SystemT Game.World m Bool
+occupied :: MonadIO m => World.Position -> Apecs.SystemT Game.World m Bool
occupied p = isJust . getAlt <$> cfoldMap go
where
- go :: Position -> Alt Maybe Position
- go x = x <$ guard (x == p)
+ go :: World.Position -> Alt Maybe World.Position
+ go x = guard (x == p) *> pure x
cfoldMap :: forall w m c a. (Apecs.Members w m c, Apecs.Get w m c, Monoid a) => (c -> a) -> Apecs.SystemT w m a
-cfoldMap f = Apecs.cfold (\a b -> a <> f b) mempty
+cfoldMap f = Apecs.cfold (\a b -> a <> f b) (mempty :: a)
setup :: (Eff.Has (State Game.State.State) sig m, MonadIO m) => Apecs.SystemT Game.World m ()
setup = do
- Apecs.newEntity (Position 3, World.Player, World.Glyph '@', World.White)
- >>= assign @GameState #player
+ Apecs.newEntity (World.Position 3, World.Player, World.Glyph '@', World.White)
+ >>= assign (field @"player" @Game.State.State)
for_ Canvas.borders \border -> do
Apecs.newEntity (border, World.Wall, World.Glyph '#', World.White)
start :: BChan Command -> MVar Action -> Game.World -> IO ()
start cmds acts world =
- let initialState = (Game.State.State (error "BUG: Tried to read uninitialized player"))
- in void
- . forkIO
- . runTrace
- . runReader cmds
- . runReader acts
- . evalState initialState
- . Apecs.runWith world
- $ setup *> forever loop
+ void
+ . forkIO
+ . runTrace
+ . runReader cmds
+ . runReader acts
+ . evalState (Game.State.State (error "BUG: Tried to read uninitialized player"))
+ . Apecs.runWith world
+ $ setup *> forever loop
diff --git a/src/Game/State.hs b/src/Game/State.hs
index 7d3bea5..cc60228 100644
--- a/src/Game/State.hs
+++ b/src/Game/State.hs
@@ -1,19 +1,10 @@
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Game.State (State (State)) where
+module Game.State where
import Apecs qualified
-import Optics
import GHC.Generics (Generic)
data State = State
- { statePlayer :: Apecs.Entity
+ { player :: Apecs.Entity
} deriving Generic
-
-makeFieldLabels ''State
diff --git a/src/Game/World.hs b/src/Game/World.hs
index c81fe1b..a36cced 100644
--- a/src/Game/World.hs
+++ b/src/Game/World.hs
@@ -8,14 +8,21 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
module Game.World (module Game.World) where
import Apecs
import Control.Algebra qualified as Eff
import Control.Carrier.Reader qualified as Eff
-import Data.Position
+import Data.Ix
+import Linear (V2 (..))
+
+newtype Position = Position (V2 Int)
+ deriving stock (Eq, Ord, Show)
+ deriving newtype (Ix, Num)
+
+make :: Int -> Int -> Position
+make x y = Position (V2 x y)
newtype Glyph = Glyph Char deriving newtype (Show)
diff --git a/src/UI/Render.hs b/src/UI/Render.hs
index 0af44fa..0e622b3 100644
--- a/src/UI/Render.hs
+++ b/src/UI/Render.hs
@@ -4,14 +4,14 @@
module UI.Render where
-import Brick qualified
-import Data.Position qualified as Position
import Game.Canvas qualified as Canvas
import Game.Canvas qualified as Game (Canvas)
import Game.World qualified as World
import Graphics.Vty qualified as Vty
import Graphics.Vty.Attributes qualified as Attr
+import Linear (V2 (..))
import UI.Resource
+import Brick qualified
drawSprite :: Canvas.Sprite -> Vty.Image
drawSprite (Canvas.Sprite (World.Glyph chr) color) = Vty.char attr chr
@@ -28,13 +28,13 @@ scanline :: Int -> Game.Canvas -> Vty.Image
scanline idx canv = do
let scanlines = do
x <- [0 .. Canvas.size]
- pure (Canvas.at canv (Position.make x idx))
+ pure (Canvas.at canv (World.Position (V2 x idx)))
let squares = fmap drawSprite scanlines
Vty.horizCat squares
render :: Game.Canvas -> Brick.Widget Resource
render canv =
let allLines = [scanline x canv | x <- [0 .. Canvas.size]]
- in Brick.viewport UI.Resource.Canvas Brick.Both
- . Brick.raw
- $ Vty.vertCat allLines
+ in Brick.viewport UI.Resource.Canvas Brick.Both
+ . Brick.raw
+ $ Vty.vertCat allLines
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment