├── Setup.hs ├── .gitignore ├── ChangeLog.md ├── .ghci ├── test └── Spec.hs ├── screenshots ├── mallrl.gif ├── indoors.png └── outdoor.png ├── resources ├── fontNumbers.png ├── font_custom.bmp ├── font_original.bmp └── names.txt ├── src └── Lib.hs ├── licenses ├── haskell_packages │ ├── sdl2_license.txt │ ├── astar_license.txt │ ├── linear_licenese.txt │ ├── apecs_license.txt │ ├── unordered-containers_license.txt │ ├── containers_license.txt │ ├── MonadRandom_license.txt │ ├── random_license.txt │ └── array_license.txt └── README-SDL.txt ├── app ├── Position.hs ├── TileImage.hs ├── RandomUtility.hs ├── Demand.hs ├── TileMap.hs ├── Room.hs ├── CDrawable.hs ├── TerminalText.hs ├── Interaction.hs ├── Colors.hs ├── Draw.hs ├── Item.hs ├── Pathfinding.hs ├── Car.hs ├── World.hs ├── UI.hs ├── Renderer.hs ├── MapGeneration.hs └── Main.hs ├── executable-license.txt ├── package.yaml ├── README.md └── stack.yaml /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | mall.cabal 3 | *~ 4 | stack.yaml.lock -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for mall 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set -fwarn-unused-binds -fwarn-unused-imports 2 | :set -isrc 3 | :load Main -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /screenshots/mallrl.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nmaehlmann/mallRL/HEAD/screenshots/mallrl.gif -------------------------------------------------------------------------------- /resources/fontNumbers.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nmaehlmann/mallRL/HEAD/resources/fontNumbers.png -------------------------------------------------------------------------------- /resources/font_custom.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nmaehlmann/mallRL/HEAD/resources/font_custom.bmp -------------------------------------------------------------------------------- /screenshots/indoors.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nmaehlmann/mallRL/HEAD/screenshots/indoors.png -------------------------------------------------------------------------------- /screenshots/outdoor.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nmaehlmann/mallRL/HEAD/screenshots/outdoor.png -------------------------------------------------------------------------------- /resources/font_original.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nmaehlmann/mallRL/HEAD/resources/font_original.bmp -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /licenses/haskell_packages/sdl2_license.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nmaehlmann/mallRL/HEAD/licenses/haskell_packages/sdl2_license.txt -------------------------------------------------------------------------------- /app/Position.hs: -------------------------------------------------------------------------------- 1 | module Position where 2 | import Linear.V2 3 | 4 | type Position = V2 Int 5 | 6 | left, right, up, down :: Position -> Position 7 | left (V2 x y) = V2 (x - 1) y 8 | right (V2 x y) = V2 (x + 1) y 9 | up (V2 x y) = V2 x (y - 1) 10 | down (V2 x y) = V2 x (y + 1) -------------------------------------------------------------------------------- /app/TileImage.hs: -------------------------------------------------------------------------------- 1 | module TileImage where 2 | import Data.Array 3 | import SDL.Vect 4 | import Foreign.C.Types 5 | import Data.Word 6 | import Position 7 | 8 | type Glyph = (V2 CInt) 9 | type Color = V3 Word8 10 | data Tile = Tile Glyph Color Color 11 | deriving (Show, Eq) 12 | data TileImage = TileImage (Array Position Tile) 13 | deriving (Eq) -------------------------------------------------------------------------------- /app/RandomUtility.hs: -------------------------------------------------------------------------------- 1 | module RandomUtility where 2 | import Apecs hiding (Map, Set) 3 | import Control.Monad.Random 4 | import World 5 | 6 | evalRandom :: Rand StdGen a -> System' a 7 | evalRandom g = lift $ evalRandIO g 8 | 9 | pickRandom :: RandomGen g => [a] -> Rand g a 10 | pickRandom l = do 11 | let ll = length l 12 | idx <- getRandomR (0, ll - 1) 13 | return $ l !! idx -------------------------------------------------------------------------------- /licenses/README-SDL.txt: -------------------------------------------------------------------------------- 1 | 2 | Please distribute this file with the SDL runtime environment: 3 | 4 | The Simple DirectMedia Layer (SDL for short) is a cross-platform library 5 | designed to make it easy to write multi-media software, such as games 6 | and emulators. 7 | 8 | The Simple DirectMedia Layer library source code is available from: 9 | https://www.libsdl.org/ 10 | 11 | This library is distributed under the terms of the zlib license: 12 | http://www.zlib.net/zlib_license.html 13 | 14 | -------------------------------------------------------------------------------- /app/Demand.hs: -------------------------------------------------------------------------------- 1 | module Demand where 2 | import Apecs hiding (Map, Set) 3 | import Pathfinding 4 | import Item 5 | import World 6 | 7 | 8 | 9 | demand :: Item -> System' Float 10 | demand i = do 11 | numberOfItems <- length <$> itemPositions i 12 | numberOfShoppinglistOccurences <- flip cfold 0 $ \x (CShoppingList sl) -> x + count i sl 13 | return $ (fromIntegral numberOfShoppinglistOccurences) / (fromIntegral numberOfItems) 14 | 15 | count :: Eq a => a -> [a] -> Int 16 | count x = length . filter (x==) -------------------------------------------------------------------------------- /app/TileMap.hs: -------------------------------------------------------------------------------- 1 | module TileMap where 2 | import Foreign.C.Types 3 | import Position 4 | import Linear 5 | 6 | mapWidth, mapHeight :: CInt 7 | mapWidth = 72 8 | mapHeight = 48 9 | 10 | arrayBounds :: (Position, Position) 11 | arrayBounds = (V2 0 0, fmap fromIntegral (V2 mapWidth mapHeight)) 12 | 13 | mapWidthInt, mapHeightInt :: Int 14 | mapWidthInt = fromIntegral mapWidth 15 | mapHeightInt = fromIntegral mapHeight 16 | 17 | xMax, yMax :: Int 18 | xMax = fromIntegral (mapWidth - 1) 19 | yMax = fromIntegral (mapHeight - 1) -------------------------------------------------------------------------------- /executable-license.txt: -------------------------------------------------------------------------------- 1 | mallRL is a game by Nikolas Mählmann. 2 | 3 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 4 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 5 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 6 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, 7 | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 8 | TORT OR OTHERWISE, ARISING FROM, 9 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /app/Room.hs: -------------------------------------------------------------------------------- 1 | module Room where 2 | import Position 3 | import Linear 4 | import Data.List 5 | 6 | data Room = Room Int Int Int Int deriving Eq 7 | data Wall = Wall Int Int Int Int 8 | 9 | shrink1 :: Room -> Room 10 | shrink1 (Room x y w h) = Room (x+1) (y+1) (w-2) (h-2) 11 | 12 | containsPosition :: Position -> Room -> Bool 13 | containsPosition (V2 px py) (Room x y w h) = px >= x - 1 && px <= x + w && py >= y - 1 && py <= y + h 14 | 15 | groundPositions :: Room -> [Position] 16 | groundPositions (Room x y w h) = [(V2 xs ys) | xs <- [x - 1 .. x + w], ys <- [y - 1 .. y + h]] 17 | 18 | allGroundPositions :: [Room] -> [Position] 19 | allGroundPositions rs = nub $ concatMap groundPositions rs -------------------------------------------------------------------------------- /app/CDrawable.hs: -------------------------------------------------------------------------------- 1 | module CDrawable where 2 | import TileImage 3 | import Position 4 | import Data.Array 5 | import Linear 6 | import TileMap 7 | 8 | data CDrawable = Drawable Glyph Color | DrawableBG Glyph Color Color 9 | 10 | type DrawingFunction = [(Position, Tile)] -> (Position, CDrawable) -> [(Position, Tile)] 11 | 12 | drawFG :: TileImage -> DrawingFunction 13 | drawFG (TileImage tm) ls (pos, Drawable glyph color) = 14 | let (Tile _ _ bgColor) = tm ! pos 15 | in (pos, Tile glyph color bgColor) : ls 16 | drawFG _ ls _= ls 17 | 18 | drawBG :: DrawingFunction 19 | drawBG ls (pos, DrawableBG glyph color bgColor) = (pos, Tile glyph color bgColor) : ls 20 | drawBG ls _ = ls 21 | 22 | drawDrawable :: DrawingFunction -> [(Position, Tile)] -> (Position, CDrawable) -> [(Position, Tile)] 23 | drawDrawable drawFun tm all@((V2 x y), d) = if x < xMax && y < yMax && x >= 0 && y >= 0 then drawFun tm all else tm -------------------------------------------------------------------------------- /resources/names.txt: -------------------------------------------------------------------------------- 1 | Agnes 2 | Albert 3 | Amalia 4 | Anna 5 | Anton 6 | Antonia 7 | Arthur 8 | August 9 | Augusta 10 | Benno 11 | Bruno 12 | Charlotte 13 | Clemens 14 | Dorothea 15 | Edda 16 | Elisa 17 | Elisabeth 18 | Elsa 19 | Emil 20 | Emma 21 | Eugen 22 | Franka 23 | Franz 24 | Franziska 25 | Frederick 26 | Frieda 27 | Friederike 28 | Friedrich 29 | Gabriel 30 | Georg 31 | Greta 32 | Gustav 33 | Hans 34 | Hagen 35 | Hedda 36 | Helene 37 | Henri 38 | Henriette 39 | Hugo 40 | Ida 41 | Johann 42 | Johanna 43 | Johannes 44 | Josephine 45 | Julius 46 | Justus 47 | Karl 48 | Karla 49 | Karolina 50 | Kaspar 51 | Katharina 52 | Konrad 53 | Konstantin 54 | Kunibert 55 | Leonhard 56 | Leopold 57 | Lorenz 58 | Ludwig 59 | Luise 60 | Michael 61 | Margarete 62 | Maria 63 | Martha 64 | Margarete 65 | Mathilda 66 | Maximilian 67 | Oskar 68 | Otto 69 | Paul 70 | Paula 71 | Richard 72 | Ruth 73 | Thea 74 | Theodor 75 | Theresa 76 | Viktoria 77 | Wilhelmine -------------------------------------------------------------------------------- /app/TerminalText.hs: -------------------------------------------------------------------------------- 1 | module TerminalText where 2 | import TileImage 3 | import CDrawable 4 | import Position 5 | import Colors 6 | import Linear 7 | import Data.Array 8 | 9 | data TerminalText = FGText String Color | BGText String Color Color | ConcatText TerminalText TerminalText | Icon CDrawable 10 | instance Semigroup TerminalText where 11 | t1 <> t2 = ConcatText t1 t2 12 | 13 | textLen :: TerminalText -> Int 14 | textLen (FGText s _) = length s 15 | textLen (BGText s _ _) = length s 16 | textLen (ConcatText t1 t2) = textLen t1 + textLen t2 17 | textLen (Icon _) = 1 18 | 19 | textToDrawables :: TerminalText -> [CDrawable] 20 | textToDrawables (FGText s c) = map (\g -> Drawable g c) $ map charToGlyph s 21 | textToDrawables (BGText s cFG cBG) = map (\g -> DrawableBG g cFG cBG) $ map charToGlyph s 22 | textToDrawables (ConcatText t1 t2) = textToDrawables t1 ++ textToDrawables t2 23 | textToDrawables (Icon d) = [d] 24 | 25 | drawText :: Position -> TerminalText -> TileImage -> TileImage 26 | drawText (V2 x y) txt (TileImage tm) = 27 | let positionedDrawables = zip [V2 xs y | xs <- [x..]] (textToDrawables txt) 28 | bgAssocs = foldl (drawDrawable drawBG) [] positionedDrawables 29 | bgImage = TileImage $ tm // bgAssocs 30 | allAssocs = foldl (drawDrawable (drawFG bgImage)) bgAssocs positionedDrawables 31 | in TileImage $ tm // allAssocs 32 | -------------------------------------------------------------------------------- /app/Interaction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 10 | {-# LANGUAGE DerivingVia #-} 11 | module Interaction (interaction, interaction_) where 12 | import Control.Monad 13 | import Apecs 14 | 15 | interaction_ :: forall w m cx cy a. (Get w m cx, Members w m cx, Get w m cy, Members w m cy) => Entity -> Entity -> (cx -> cy -> SystemT w m a) -> SystemT w m () 16 | interaction_ e1 e2 f = interaction e1 e2 f >> return () 17 | 18 | interaction :: forall w m cx cy a. (Get w m cx, Members w m cx, Get w m cy, Members w m cy) => Entity -> Entity -> (cx -> cy -> SystemT w m a) -> SystemT w m (Maybe a) 19 | interaction e1 e2 f = join <$> (doIfPossible' e1 (\c -> doIfPossible' e2 (f c))) 20 | 21 | doIfPossible' :: forall w m cx a. (Get w m cx, Members w m cx) => Entity -> (cx -> SystemT w m a) -> SystemT w m (Maybe a) 22 | doIfPossible' e f = doIfPossible e f Proxy 23 | 24 | doIfPossible :: forall w m cx a. (Get w m cx, Members w m cx) => Entity -> (cx -> SystemT w m a) -> Proxy cx -> SystemT w m (Maybe a) 25 | doIfPossible e f p = do 26 | ex <- exists e p 27 | if ex then do 28 | cx <- get e 29 | Just <$> f cx 30 | else return Nothing 31 | -------------------------------------------------------------------------------- /licenses/haskell_packages/astar_license.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008, Cale Gibbard; 2016, Johannes Weiss 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | * Neither the name of Cale Gibbard nor the names of any contributors to this software may be used to endorse or promote products derived from this software without specific prior written permission. 9 | 10 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /licenses/haskell_packages/linear_licenese.txt: -------------------------------------------------------------------------------- 1 | Copyright 2011-2015 Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 21 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /licenses/haskell_packages/apecs_license.txt: -------------------------------------------------------------------------------- 1 | Copyright Jonas Carpay (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Jonas Carpay nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /licenses/haskell_packages/unordered-containers_license.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010, Johan Tibell 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Johan Tibell nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /licenses/haskell_packages/containers_license.txt: -------------------------------------------------------------------------------- 1 | The Glasgow Haskell Compiler License 2 | 3 | Copyright 2004, The University Court of the University of Glasgow. 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | - Redistributions of source code must retain the above copyright notice, 10 | this list of conditions and the following disclaimer. 11 | 12 | - Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | - Neither name of the University nor the names of its contributors may be 17 | used to endorse or promote products derived from this software without 18 | specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF 21 | GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 22 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 23 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE 25 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 27 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 31 | DAMAGE. -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: mall 2 | version: 0.1.0.0 3 | github: "githubuser/mall" 4 | license: 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2020 Author name here" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | 28 | executables: 29 | mall-exe: 30 | main: Main.hs 31 | source-dirs: app 32 | # cpp-options: -D_SDL_main_h -DSDL_main_h_ 33 | ghc-options: 34 | - -threaded 35 | - -rtsopts 36 | - -with-rtsopts=-N 37 | - -optl-mconsole 38 | - -optl-mwindows 39 | # profiling 40 | # - -prof 41 | # - -fprof-auto 42 | # - -fprof-cafs 43 | # - --enable-library-profiling 44 | # profiling 45 | 46 | dependencies: 47 | - mall 48 | - sdl2 49 | - array 50 | - apecs 51 | - linear 52 | - containers 53 | - astar 54 | - unordered-containers 55 | - random 56 | - MonadRandom 57 | 58 | 59 | tests: 60 | mall-test: 61 | main: Spec.hs 62 | source-dirs: test 63 | ghc-options: 64 | - -threaded 65 | - -rtsopts 66 | - -with-rtsopts=-N 67 | dependencies: 68 | - mall 69 | -------------------------------------------------------------------------------- /licenses/haskell_packages/MonadRandom_license.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Brent Yorgey 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Brent Yorgey nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | Previous versions of this package were distributed under the simple 33 | permissive license used on the Haskell Wiki; see OLD-LICENSE for 34 | details. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # mallRL 2 | 3 | mallRL is a grocery shopping roguelike developed for the 7DRL game jam. 4 | A binary version can be downloaded here: https://nmaehlmann.itch.io/mallrl 5 | 6 | ![GIF showing mallRL](https://github.com/nmaehlmann/mallRL/blob/master/screenshots/mallrl.gif) 7 | 8 | As the game was developed under strict time constraints the code is neither well organized nor high quality, but might still be interesting for people looking to develop a game in haskell. 9 | 10 | The jam version is tagged as 7drl-release and was developed from monday 02.03.2020 to sunday 08.03.2020. The week before the jam I took 2 days to prepare the technical side, as I was developing the game from scratch without an engine using SDL2 and an ECS library. After my preparation I had the ECS library included, was able to read keyboard inputs and render tiles. On monday I started the jam with a tile that could be moved on screen. 11 | 12 | ## Building on Windows 13 | ### 1. Install SDL2 via stack & pacman: 14 | 15 | ```stack exec -- pacman -Syu``` 16 | 17 | ```stack exec -- pacman -S mingw-w64-x86_64-pkg-config mingw-w64-x86_64-SDL2``` 18 | 19 | ### 2. Edit stack.yaml and remove integersimple ghc 20 | 21 | The current code uses a custom compiled ghc for license reasons (see: https://ro-che.info/articles/2017-03-10-haskell-without-gmp). Since you may only compile the game for private use, you can comment out the following lines in the ```stack.yaml``` 22 | 23 | ``` 24 | # ghc-variant: integersimple 25 | 26 | # setup-info: 27 | # ghc: 28 | # windows64-integersimple: 29 | # 8.6.5: 30 | # url: "C:/Users/Nikolas/Downloads/ghc-8.6.5-x86_64-unknown-mingw32.tar.xz" 31 | ``` 32 | 33 | and 34 | 35 | ``` 36 | # flags: 37 | # # text: 38 | # # integer-simple: true 39 | # hashable: 40 | # integer-gmp: false 41 | # scientific: 42 | # integer-simple: true 43 | # integer-logarithms: 44 | # integer-gmp: false 45 | ``` 46 | 47 | ### 3. Build and install via stack: 48 | 49 | ```stack install``` 50 | 51 | ```stack run``` 52 | -------------------------------------------------------------------------------- /app/Colors.hs: -------------------------------------------------------------------------------- 1 | module Colors where 2 | import TileImage 3 | import Linear 4 | import CDrawable 5 | import Data.Char (ord) 6 | 7 | tileEmpty = Tile filledGlyph black black 8 | 9 | ground1 = Tile groundGlyph1 groundFGColor groundBGColor 10 | ground2 = Tile groundGlyph1 groundFGColor groundBGColor 11 | groundGlyph1 = V2 14 15 12 | groundGlyph2 = V2 4 0 13 | groundFGColor = V3 255 178 102 14 | groundBGColor = V3 255 140 103 15 | 16 | dMallRoof = DrawableBG (charToGlyph '/') black white 17 | 18 | dGround = DrawableBG groundGlyph1 groundFGColor groundBGColor 19 | 20 | dLineV = Drawable (V2 3 11) white 21 | dLineH = Drawable (V2 4 12) white 22 | dCross = Drawable (V2 5 12) white 23 | 24 | dPlayerIndoors = Drawable playerGlyph playerColorIndoors 25 | dPlayerOutdoors = Drawable playerGlyph playerColorOutdoors 26 | playerGlyph = charToGlyph '@' 27 | playerColorIndoors = black 28 | playerColorOutdoors = white 29 | 30 | 31 | npcColor = grey 32 | 33 | dWall = Drawable wallGlyph wallColor 34 | wallGlyph = V2 11 13 35 | wallColor = white 36 | 37 | dShoppingCart = Drawable shoppingCartGlyph shoppingCartColor 38 | shoppingCartGlyph = V2 3 2 39 | shoppingCartColor = white 40 | 41 | dShelf = DrawableBG shelfGlyph shelfFGColor shelfBGColor 42 | shelfGlyph = V2 1 11 43 | shelfFGColor = white 44 | shelfBGColor = V3 158 158 158 45 | 46 | dShelfNorth = Drawable shelfNorthGlyph white 47 | shelfNorthGlyph = V2 12 13 48 | 49 | dShelfSouth = Drawable shelfSouthGlyph white 50 | shelfSouthGlyph = V2 15 13 51 | 52 | dShelfWest = Drawable shelfWestGlyph white 53 | shelfWestGlyph = V2 14 13 54 | 55 | dShelfEast = Drawable shelfEastGlyph white 56 | shelfEastGlyph = V2 13 13 57 | 58 | filledGlyph = V2 11 13 59 | heartGlyph :: Glyph 60 | heartGlyph = V2 3 0 61 | 62 | black, white, red, grey, green :: Color 63 | black = V3 0 0 0 64 | white = V3 255 255 255 65 | red = V3 255 0 0 66 | grey = V3 80 80 80 67 | green = V3 0 150 0 68 | 69 | charToGlyph :: Char -> Glyph 70 | charToGlyph c = 71 | let oc = ord c 72 | x = oc `mod` 16 73 | y = oc `div` 16 74 | in V2 (fromIntegral x) (fromIntegral y) -------------------------------------------------------------------------------- /app/Draw.hs: -------------------------------------------------------------------------------- 1 | module Draw where 2 | import Apecs hiding (Map, Set) 3 | import Linear 4 | import TileImage 5 | import Position 6 | import Renderer 7 | import TileMap 8 | import CDrawable 9 | import World 10 | import UI 11 | import Room 12 | import Colors 13 | import Data.Array 14 | 15 | cDrawOutdoors :: DrawingFunction -> Position -> Room -> [(Position, Tile)] -> (CPosition, CDrawable) -> [(Position, Tile)] 16 | cDrawOutdoors drawFun playerPosition mallRoom tm drawInfo@(CPosition pos, _) = 17 | if containsPosition pos (shrink1 mallRoom) 18 | then cDrawWithCam drawFun playerPosition tm (CPosition pos, dMallRoof) 19 | else cDrawWithCam drawFun playerPosition tm drawInfo 20 | 21 | cDrawIndoors :: DrawingFunction -> Position -> [Room] -> [(Position, Tile)] -> (CPosition, CDrawable) -> [(Position, Tile)] 22 | cDrawIndoors drawFun playerPosition roomsToDraw tm drawInfo@(CPosition pos, _) = 23 | if elem True $ map (containsPosition pos) roomsToDraw 24 | then cDrawWithCam drawFun playerPosition tm drawInfo 25 | else tm 26 | 27 | cDrawWithCam :: DrawingFunction -> Position -> [(Position, Tile)] -> (CPosition, CDrawable) -> [(Position, Tile)] 28 | cDrawWithCam drawFun (V2 playerX playerY) tm (CPosition pos, drawable) = drawDrawable drawFun tm (pos + camera, drawable) 29 | where 30 | camera = V2 xOff yOff 31 | xOff = (div (mapWidthInt - sidebarSize) 2) - playerX 32 | yOff = (div (mapHeightInt - logSize) 2) - playerY 33 | 34 | draw :: System' TileImage 35 | draw = do 36 | (CMallRoom mallRoom) <- get global 37 | let drawLayer drawFun tileImage = flip cfoldM emptyMap $ \tm (CPlayer, CPosition playerPosition, CIsInRoom roomsToDraw) -> do 38 | let cDraw = if containsPosition playerPosition mallRoom 39 | then cDrawIndoors drawFun playerPosition roomsToDraw 40 | else cDrawOutdoors drawFun playerPosition mallRoom 41 | newAssocs <- cfold cDraw [] 42 | let (TileImage emptyArr) = tileImage 43 | (return (TileImage (emptyArr // (reverse newAssocs)))) :: System' TileImage 44 | bg <- drawLayer drawBG emptyMap 45 | drawLayer (drawFG bg) bg >>= drawUI -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-14.20 21 | 22 | ghc-variant: integersimple 23 | 24 | setup-info: 25 | ghc: 26 | windows64-integersimple: 27 | 8.6.5: 28 | url: "C:/Users/Nikolas/Downloads/ghc-8.6.5-x86_64-unknown-mingw32.tar.xz" 29 | 30 | extra-deps: 31 | - astar-0.3.0.0 32 | 33 | flags: 34 | # text: 35 | # integer-simple: true 36 | hashable: 37 | integer-gmp: false 38 | scientific: 39 | integer-simple: true 40 | integer-logarithms: 41 | integer-gmp: false 42 | 43 | 44 | # User packages to be built. 45 | # Various formats can be used as shown in the example below. 46 | # 47 | # packages: 48 | # - some-directory 49 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 50 | # subdirs: 51 | # - auto-update 52 | # - wai 53 | packages: 54 | - . 55 | # Dependency packages to be pulled from upstream that are not in the resolver. 56 | # These entries can reference officially published versions as well as 57 | # forks / in-progress versions pinned to a git hash. For example: 58 | # 59 | # extra-deps: 60 | # - acme-missiles-0.3 61 | # - git: https://github.com/commercialhaskell/stack.git 62 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 63 | # 64 | # extra-deps: [] 65 | 66 | # Override default flag values for local packages and extra-deps 67 | # flags: {} 68 | 69 | # Extra package databases containing global packages 70 | # extra-package-dbs: [] 71 | 72 | # Control whether we use the GHC we find on the path 73 | # system-ghc: true 74 | # 75 | # Require a specific version of stack, using version ranges 76 | # require-stack-version: -any # Default 77 | # require-stack-version: ">=2.1" 78 | # 79 | # Override the architecture used by stack, especially useful on Windows 80 | # arch: i386 81 | # arch: x86_64 82 | # 83 | # Extra directories used by stack for building 84 | # extra-include-dirs: [/path/to/dir] 85 | # extra-lib-dirs: [/path/to/dir] 86 | # 87 | # Allow a newer minor version of GHC than the snapshot specifies 88 | # compiler-check: newer-minor 89 | -------------------------------------------------------------------------------- /app/Item.hs: -------------------------------------------------------------------------------- 1 | module Item where 2 | import Colors 3 | import CDrawable 4 | import Linear 5 | 6 | data Item = Pizza | Seaweed | Bananas | Fishsticks | Nachos | Apples| Donut | Chocolate | Oranges | Grapes | Lightbulb | Mustard | Ketchup 7 | deriving (Eq, Show, Ord) 8 | 9 | allItems = [Pizza, Seaweed, Bananas, Fishsticks, Nachos, Apples, Donut, Chocolate, Oranges, Grapes, Lightbulb, Mustard, Ketchup] 10 | 11 | lookupItemDrawable :: Item -> CDrawable 12 | lookupItemDrawable Pizza = dPizza 13 | lookupItemDrawable Seaweed = dSeaweed 14 | lookupItemDrawable Bananas = dBananas 15 | lookupItemDrawable Fishsticks = dFishsticks 16 | lookupItemDrawable Nachos = dNachos 17 | lookupItemDrawable Apples = dApples 18 | lookupItemDrawable Donut = dDonut 19 | lookupItemDrawable Chocolate = dChocoloate 20 | lookupItemDrawable Oranges = dOranges 21 | lookupItemDrawable Grapes = dGrapes 22 | lookupItemDrawable Lightbulb = dLightbulb 23 | lookupItemDrawable Mustard = dMustard 24 | lookupItemDrawable Ketchup = dKetchup 25 | 26 | dPizza = DrawableBG pizzaGlyph pizzaFG pizzaBG 27 | pizzaGlyph = V2 15 4 28 | pizzaFG = V3 222 222 222 29 | pizzaBG = V3 217 0 0 30 | 31 | dSeaweed = DrawableBG seaweedGlyph seaweedFG seaweedBG 32 | seaweedGlyph = V2 7 15 33 | seaweedFG = V3 0 102 2 34 | seaweedBG = black 35 | 36 | dBananas = DrawableBG bananasGlyph bananasFG bananasBG 37 | bananasGlyph = V2 15 10 38 | bananasFG = V3 255 255 102 39 | bananasBG = black 40 | 41 | dFishsticks = DrawableBG fishsticksGlyph fishsticksFG fishsticksBG 42 | fishsticksGlyph = V2 13 3 43 | fishsticksFG = V3 255 178 102 44 | fishsticksBG = V3 51 153 255 45 | 46 | dNachos = DrawableBG nachosGlyph nachosFG nachosBG 47 | nachosGlyph = V2 15 1 48 | nachosFG = V3 255 204 51 49 | nachosBG = V3 0 0 102 50 | 51 | dApples = DrawableBG applesGlyph applesFG applesBG 52 | applesGlyph = V2 5 9 53 | applesFG = V3 217 0 0 54 | applesBG = V3 163 217 0 55 | 56 | dDonut = DrawableBG donutGlyph donutFG donutBG 57 | donutGlyph = V2 9 0 58 | donutFG = V3 255 102 178 59 | donutBG = V3 102 82 105 60 | 61 | dChocoloate = DrawableBG chocoloateGlyph chocoloateFG chocoloateBG 62 | chocoloateGlyph = V2 3 2 63 | chocoloateFG = black 64 | chocoloateBG = V3 137 72 72 65 | 66 | dOranges = DrawableBG orangesGlyph orangesFG orangesBG 67 | orangesGlyph = V2 10 0 68 | orangesFG = V3 255 178 102 69 | orangesBG = V3 51 153 255 70 | 71 | dGrapes = DrawableBG grapesGlyph grapesFG grapesBG 72 | grapesGlyph = V2 5 0 73 | grapesFG = V3 255 102 255 74 | grapesBG = V3 70 140 0 75 | 76 | dLightbulb = DrawableBG lightbulbGlyph lightbulbFG lightbulbBG 77 | lightbulbGlyph = V2 15 0 78 | lightbulbFG = V3 255 255 51 79 | lightbulbBG = V3 191 191 191 80 | 81 | dMustard = DrawableBG mustardGlyph mustardFG mustardBG 82 | mustardGlyph = V2 0 1 83 | mustardFG = V3 255 255 51 84 | mustardBG = V3 191 191 191 85 | 86 | dKetchup = DrawableBG ketchupGlyph ketchupFG ketchupBG 87 | ketchupGlyph = V2 0 1 88 | ketchupFG = V3 255 0 0 89 | ketchupBG = V3 191 191 191 90 | -------------------------------------------------------------------------------- /licenses/haskell_packages/random_license.txt: -------------------------------------------------------------------------------- 1 | This library (libraries/base) is derived from code from two 2 | sources: 3 | 4 | * Code from the GHC project which is largely (c) The University of 5 | Glasgow, and distributable under a BSD-style license (see below), 6 | 7 | * Code from the Haskell 98 Report which is (c) Simon Peyton Jones 8 | and freely redistributable (but see the full license for 9 | restrictions). 10 | 11 | The full text of these licenses is reproduced below. Both of the 12 | licenses are BSD-style or compatible. 13 | 14 | ----------------------------------------------------------------------------- 15 | 16 | The Glasgow Haskell Compiler License 17 | 18 | Copyright 2004, The University Court of the University of Glasgow. 19 | All rights reserved. 20 | 21 | Redistribution and use in source and binary forms, with or without 22 | modification, are permitted provided that the following conditions are met: 23 | 24 | - Redistributions of source code must retain the above copyright notice, 25 | this list of conditions and the following disclaimer. 26 | 27 | - Redistributions in binary form must reproduce the above copyright notice, 28 | this list of conditions and the following disclaimer in the documentation 29 | and/or other materials provided with the distribution. 30 | 31 | - Neither name of the University nor the names of its contributors may be 32 | used to endorse or promote products derived from this software without 33 | specific prior written permission. 34 | 35 | THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF 36 | GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 37 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 38 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 39 | UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE 40 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 41 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 42 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 43 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 44 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 45 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 46 | DAMAGE. 47 | 48 | ----------------------------------------------------------------------------- 49 | 50 | Code derived from the document "Report on the Programming Language 51 | Haskell 98", is distributed under the following license: 52 | 53 | Copyright (c) 2002 Simon Peyton Jones 54 | 55 | The authors intend this Report to belong to the entire Haskell 56 | community, and so we grant permission to copy and distribute it for 57 | any purpose, provided that it is reproduced in its entirety, 58 | including this Notice. Modified versions of this Report may also be 59 | copied and distributed for any purpose, provided that the modified 60 | version is clearly presented as such, and that it does not claim to 61 | be a definition of the Haskell 98 Language. 62 | 63 | ----------------------------------------------------------------------------- -------------------------------------------------------------------------------- /app/Pathfinding.hs: -------------------------------------------------------------------------------- 1 | module Pathfinding where 2 | import Apecs hiding (Map, Set) 3 | import Linear 4 | import Position 5 | import Item 6 | import World 7 | import Data.HashSet (HashSet) 8 | import qualified Data.HashSet as HashSet 9 | import Data.Graph.AStar 10 | import Control.Monad 11 | import Room 12 | 13 | pathToItem :: Position -> Item -> System' (Maybe [Position]) 14 | pathToItem currentPosition item = do 15 | itemPositions <- flip cfold [] $ \l (CItem i, CPosition p) -> if item == i 16 | then p:l 17 | else l 18 | case itemPositions of 19 | [] -> return Nothing 20 | (goal : _) -> pathToPosition currentPosition goal 21 | 22 | pathToPosition :: Position -> Position -> System' (Maybe [Position]) 23 | pathToPosition currentPosition goal = do 24 | (CMallRoom mallRoom) <- get global 25 | let bothPositionsInMall = containsPosition goal mallRoom && containsPosition currentPosition mallRoom 26 | let neighboursFun = if bothPositionsInMall then neighboursInMall mallRoom else neighbours 27 | aStarM 28 | (neighboursFun goal) 29 | distanceBetweenNeighbours 30 | (heuristicDistanceToGoal goal) 31 | (\p -> return (p == goal)) 32 | (return currentPosition) 33 | 34 | positionValid :: Position -> Bool 35 | positionValid (V2 x y) = x < positionMaxX && y < positionMaxY && x >= 0 && y >= 0 36 | 37 | itemPositions :: Item -> System' [Position] 38 | itemPositions item = flip cfold [] $ \l (CItem i, CPosition p) -> if item == i then p:l else l 39 | 40 | isItemSoldOut :: Item -> System' Bool 41 | isItemSoldOut i = null <$> itemPositions i 42 | 43 | isItemOnPosition :: Item -> Position -> System' Bool 44 | isItemOnPosition item pos = do 45 | entities <- entitiesAtPosition pos 46 | not <$> null <$> filterM (\e -> e `isItem` item) entities 47 | 48 | isItem :: Entity -> Item -> System' Bool 49 | isItem e item = do 50 | isAnItem <- exists e (Proxy :: Proxy CItem) 51 | if isAnItem then do 52 | (CItem i) <- get e 53 | return $ i == item 54 | else return False 55 | 56 | neighboursInMall :: Room -> Position -> Position -> System' (HashSet Position) 57 | neighboursInMall mallRoom goal p = do 58 | ps <- mapM (filterFreePosition goal) $ filter (\pos -> containsPosition pos mallRoom) $ filter positionValid $ [left, right, up, down] <*> [p] 59 | return $ HashSet.unions ps 60 | 61 | 62 | neighbours :: Position -> Position -> System' (HashSet Position) 63 | neighbours goal p = do 64 | ps <- mapM (filterFreePosition goal) $ filter positionValid $ [left, right, up, down] <*> [p] 65 | return $ HashSet.unions ps 66 | 67 | distanceBetweenNeighbours :: Position -> Position -> System' Float 68 | distanceBetweenNeighbours _ _ = return 1 69 | 70 | heuristicDistanceToGoal :: Position -> Position -> System' Float 71 | heuristicDistanceToGoal goal p = return $ distance (fmap (fromIntegral) goal) (fmap (fromIntegral) p) 72 | 73 | filterFreePosition :: Position -> Position -> System' (HashSet Position) 74 | filterFreePosition goal target = if goal == target 75 | then return $ HashSet.singleton target 76 | else do 77 | entitiesAtTarget <- entitiesAtPosition target 78 | targetBlocked <- containsSolidEntity entitiesAtTarget 79 | return $ if targetBlocked then HashSet.empty else HashSet.singleton target 80 | 81 | containsSolidEntity :: [Entity] -> System' Bool 82 | containsSolidEntity es = elem True <$> mapM (\e -> exists e (Proxy :: Proxy CSolid)) es -------------------------------------------------------------------------------- /app/Car.hs: -------------------------------------------------------------------------------- 1 | module Car where 2 | import Control.Monad.Random 3 | import Apecs hiding (Map, Set) 4 | import Linear 5 | import Colors 6 | import World 7 | import CDrawable 8 | import TileImage 9 | import RandomUtility 10 | 11 | flipV (DrawableBG g c1 c2) = DrawableBG g c2 c1 12 | flipV a = a 13 | 14 | windowColor = V3 102 178 255 15 | 16 | carTop cMain cSide = Drawable (V2 12 13) cMain 17 | carTireLeftTop cMain cSide = DrawableBG (V2 13 13) grey cSide 18 | carTireRightTop cMain cSide = flipV $ carTireLeftTop cMain cSide 19 | carRoof cMain cSide = DrawableBG (V2 0 15) black cSide 20 | carSideLeft cMain cSide = DrawableBG (V2 13 13) cMain cSide 21 | carSideRight cMain cSide = flipV $ carSideLeft cMain cSide 22 | carWindowLeft cMain cSide = DrawableBG (V2 13 13) cMain windowColor 23 | carWindowRight cMain cSide = flipV $ carWindowLeft cMain cSide 24 | carWindowMiddle cMain cSide = DrawableBG (V2 1 11) white windowColor 25 | carTireLeftBot cMain cSide = DrawableBG (V2 13 13) grey cMain 26 | carTireRightBot cMain cSide = flipV $ carTireLeftBot cMain cSide 27 | carFrontLeft cMain cSide = DrawableBG (V2 10 13) black cMain 28 | carFrontRight cMain cSide = DrawableBG (V2 15 11) black cMain 29 | carFrontMiddle cMain cSide = DrawableBG (V2 7 13) black cMain 30 | carMiddle cMain cSide = DrawableBG (V2 10 11) black cMain 31 | 32 | car = 33 | [ [carTop, carTop, carTop] 34 | , [carTireLeftTop, carRoof, carTireRightTop] 35 | , [carSideLeft, carRoof, carSideRight] 36 | , [carSideLeft, carRoof, carSideRight] 37 | , [carWindowLeft, carWindowMiddle, carWindowRight] 38 | , [carTireLeftBot, carMiddle, carTireRightBot] 39 | , [carFrontLeft, carFrontMiddle, carFrontRight] 40 | ] 41 | 42 | carWidth = 3 43 | carHeight = 7 44 | 45 | mkParkingLot :: Int -> Int -> Int -> System' [CCar] 46 | mkParkingLot xOff yOff cols = do 47 | result <- flip mapM [0..(cols-1)] $ \col -> do 48 | let xOffC = xOff + col * (carWidth + 3) 49 | car1 <- mkCar xOffC yOff 50 | mkCarLineH (xOffC - 1) (yOff + carHeight) 51 | car2 <- mkCar xOffC (yOff + carHeight + 1) 52 | when (col /= (cols - 1)) $ do 53 | newEntity (CPosition (V2 ((carWidth + 1) + xOffC) (yOff + carHeight)), dCross) 54 | mkCarLineV ((carWidth + 1) + xOffC) yOff 55 | mkCarLineV ((carWidth + 1) + xOffC) (yOff + carHeight + 1) 56 | return [car1, car2] 57 | return $ join result 58 | 59 | mkCarLineV :: Int -> Int -> System' () 60 | mkCarLineV xOff yOff = do 61 | flip mapM_ [(V2 xOff (y + yOff)) | y <- [0 .. carHeight - 1]] $ \p -> do 62 | newEntity (CPosition p, dLineV) 63 | 64 | mkCarLineH :: Int -> Int -> System' () 65 | mkCarLineH xOff yOff = do 66 | flip mapM_ [(V2 (x + xOff) yOff) | x <- [0 .. carWidth + 1]] $ \p -> do 67 | newEntity (CPosition p, dLineH) 68 | 69 | data CarColors = CarColors Color Color 70 | 71 | carBlue :: CarColors 72 | carBlue = CarColors (V3 0 51 102) (V3 0 89 178) 73 | 74 | carRed :: CarColors 75 | carRed = CarColors (V3 178 0 0) (V3 217 0 0) 76 | 77 | carYellow :: CarColors 78 | carYellow = CarColors (V3 217 217 0) (V3 255 255 0) 79 | 80 | mkCar :: Int -> Int -> System' CCar 81 | mkCar xOff yOff = do 82 | let carId = CCar (V2 xOff yOff) 83 | (CarColors colMain colSide) <- evalRandom $ pickRandom [carYellow, carRed, carBlue] 84 | flip mapM_ [(V2 x y) | x <- [0..2], y <- [0..6]] $ \p@(V2 x y) -> do 85 | newEntity (CPosition (p + (V2 xOff yOff)), (car !! y !! x) colMain colSide, CSolid, carId) 86 | return carId 87 | -------------------------------------------------------------------------------- /licenses/haskell_packages/array_license.txt: -------------------------------------------------------------------------------- 1 | This library (libraries/base) is derived from code from several 2 | sources: 3 | 4 | * Code from the GHC project which is largely (c) The University of 5 | Glasgow, and distributable under a BSD-style license (see below), 6 | 7 | * Code from the Haskell 98 Report which is (c) Simon Peyton Jones 8 | and freely redistributable (but see the full license for 9 | restrictions). 10 | 11 | * Code from the Haskell Foreign Function Interface specification, 12 | which is (c) Manuel M. T. Chakravarty and freely redistributable 13 | (but see the full license for restrictions). 14 | 15 | The full text of these licenses is reproduced below. All of the 16 | licenses are BSD-style or compatible. 17 | 18 | ----------------------------------------------------------------------------- 19 | 20 | The Glasgow Haskell Compiler License 21 | 22 | Copyright 2004, The University Court of the University of Glasgow. 23 | All rights reserved. 24 | 25 | Redistribution and use in source and binary forms, with or without 26 | modification, are permitted provided that the following conditions are met: 27 | 28 | - Redistributions of source code must retain the above copyright notice, 29 | this list of conditions and the following disclaimer. 30 | 31 | - Redistributions in binary form must reproduce the above copyright notice, 32 | this list of conditions and the following disclaimer in the documentation 33 | and/or other materials provided with the distribution. 34 | 35 | - Neither name of the University nor the names of its contributors may be 36 | used to endorse or promote products derived from this software without 37 | specific prior written permission. 38 | 39 | THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF 40 | GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 41 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 42 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 43 | UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE 44 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 45 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 46 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 47 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 48 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 49 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 50 | DAMAGE. 51 | 52 | ----------------------------------------------------------------------------- 53 | 54 | Code derived from the document "Report on the Programming Language 55 | Haskell 98", is distributed under the following license: 56 | 57 | Copyright (c) 2002 Simon Peyton Jones 58 | 59 | The authors intend this Report to belong to the entire Haskell 60 | community, and so we grant permission to copy and distribute it for 61 | any purpose, provided that it is reproduced in its entirety, 62 | including this Notice. Modified versions of this Report may also be 63 | copied and distributed for any purpose, provided that the modified 64 | version is clearly presented as such, and that it does not claim to 65 | be a definition of the Haskell 98 Language. 66 | 67 | ----------------------------------------------------------------------------- 68 | 69 | Code derived from the document "The Haskell 98 Foreign Function 70 | Interface, An Addendum to the Haskell 98 Report" is distributed under 71 | the following license: 72 | 73 | Copyright (c) 2002 Manuel M. T. Chakravarty 74 | 75 | The authors intend this Report to belong to the entire Haskell 76 | community, and so we grant permission to copy and distribute it for 77 | any purpose, provided that it is reproduced in its entirety, 78 | including this Notice. Modified versions of this Report may also be 79 | copied and distributed for any purpose, provided that the modified 80 | version is clearly presented as such, and that it does not claim to 81 | be a definition of the Haskell 98 Foreign Function Interface. 82 | 83 | ----------------------------------------------------------------------------- -------------------------------------------------------------------------------- /app/World.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 10 | {-# LANGUAGE DerivingVia #-} 11 | module World where 12 | import Apecs hiding (Map, Set) 13 | import qualified Apecs as Apecs 14 | import Linear 15 | import Position 16 | import Data.Array 17 | import CDrawable 18 | import Item 19 | import Apecs.Experimental.Reactive 20 | import TerminalText 21 | import Room 22 | 23 | positionMaxX = 100 24 | positionMaxY = 64 25 | 26 | shoppingListBuffer :: Int 27 | shoppingListBuffer = 5 28 | 29 | newtype CPosition = CPosition Position 30 | deriving (Show, Eq, Ord) 31 | deriving (Ix) via Position 32 | instance Component CPosition where type Storage CPosition = Reactive (IxMap CPosition) (Apecs.Map CPosition) 33 | instance Bounded CPosition where 34 | minBound = CPosition (V2 0 0) 35 | maxBound = CPosition (V2 positionMaxX positionMaxY) 36 | 37 | data CPlayer = CPlayer deriving Show 38 | instance Component CPlayer where type Storage CPlayer = Unique CPlayer 39 | 40 | instance Component CDrawable where type Storage CDrawable = Apecs.Map CDrawable 41 | 42 | data CItem = CItem Item 43 | instance Component CItem where type Storage CItem = Apecs.Map CItem 44 | 45 | data CSolid = CSolid 46 | instance Component CSolid where type Storage CSolid = Apecs.Map CSolid 47 | 48 | data CInventory = CInventory [Item] 49 | instance Component CInventory where type Storage CInventory = Apecs.Map CInventory 50 | 51 | newtype CActions = CActions [Action] 52 | deriving (Monoid, Semigroup) via ([Action]) 53 | instance Component CActions where type Storage CActions = Apecs.Global CActions 54 | 55 | data CShoppingList = CShoppingList [Item] 56 | instance Component CShoppingList where type Storage CShoppingList = Apecs.Map CShoppingList 57 | 58 | data Behaviour = Buy Item [Position] | Deciding 59 | deriving Eq 60 | 61 | newtype CBehaviour = CBehaviour Behaviour 62 | instance Component CBehaviour where type Storage CBehaviour = Apecs.Map CBehaviour 63 | 64 | data Action = Move Direction | Redisplay 65 | 66 | data Direction = DirUp | DirDown | DirLeft | DirRight 67 | 68 | newtype CLog = CLog [TerminalText] 69 | deriving (Monoid, Semigroup) via ([TerminalText]) 70 | instance Component CLog where type Storage CLog = Apecs.Global CLog 71 | 72 | newtype CTime = CTime Float 73 | instance Component CTime where type Storage CTime = Apecs.Global CTime 74 | instance Semigroup CTime where (CTime t1) <> (CTime t2) = CTime (t1 + t2) 75 | instance Monoid CTime where mempty = CTime 0 76 | 77 | newtype CIsInRoom = CIsInRoom [Room] 78 | instance Component CIsInRoom where type Storage CIsInRoom = Apecs.Map CIsInRoom 79 | 80 | newtype CName = CName String 81 | instance Component CName where type Storage CName = Apecs.Map CName 82 | 83 | newtype CCar = CCar Position 84 | instance Component CCar where type Storage CCar = Apecs.Map CCar 85 | 86 | newtype COwnsCar = COwnsCar Position 87 | instance Component COwnsCar where type Storage COwnsCar = Apecs.Map COwnsCar 88 | 89 | newtype CMallRoom = CMallRoom Room 90 | instance Component CMallRoom where type Storage CMallRoom = Apecs.Global CMallRoom 91 | instance Semigroup CMallRoom where m1 <> m2 = m1 -- :( 92 | instance Monoid CMallRoom where mempty = CMallRoom $ Room 0 0 positionMaxX positionMaxY 93 | 94 | data CGameState = Running Int | Stopped deriving Eq 95 | instance Component CGameState where type Storage CGameState = Apecs.Global CGameState 96 | instance Semigroup CGameState where m1 <> m2 = m1 -- :( 97 | instance Monoid CGameState where mempty = Running 0 98 | 99 | makeWorld "World" [''CPosition, ''CPlayer, ''CDrawable, ''CSolid, ''CItem, ''CInventory 100 | , ''CTime, ''CActions, ''CBehaviour, ''CLog, ''CName, ''CShoppingList, ''CIsInRoom, ''CCar, ''COwnsCar, ''CMallRoom, ''CGameState] 101 | 102 | destroyEntity :: Entity -> System' () 103 | destroyEntity e = destroy e (Proxy :: Proxy ((CPosition, CPlayer, CDrawable, CSolid, CItem, CInventory), (CBehaviour, CName, CIsInRoom, CCar, COwnsCar))) 104 | 105 | type System' a = System World a 106 | 107 | entitiesAtPosition :: Position -> System' [Entity] 108 | entitiesAtPosition pos = withReactive $ ixLookup (CPosition pos) -------------------------------------------------------------------------------- /app/UI.hs: -------------------------------------------------------------------------------- 1 | module UI where 2 | import Apecs hiding (Map, Set) 3 | import Linear 4 | import TileImage 5 | import Position 6 | import Data.Array 7 | import Colors 8 | import TileMap 9 | import CDrawable 10 | import Item 11 | import World 12 | import TerminalText 13 | import Data.List 14 | 15 | logSize :: Int 16 | logSize = 5 17 | 18 | sidebarSize :: Int 19 | sidebarSize = 18 20 | 21 | drawLog :: TileImage -> System' TileImage 22 | drawLog (TileImage arr) = do 23 | let bg = fill black $ rect (V2 0 (yMax - logSize + 1 - 2)) mapWidthInt (logSize + 2) 24 | let tm = TileImage $ arr // bg 25 | (CLog txts) <- get global 26 | let paddedTxts = take logSize $ leftPad logSize (FGText "" black) txts 27 | let logPositions = [(V2 1 (y - 1)) | y <- (decrease yMax)] 28 | return $ applyToPairs drawText tm $ zip logPositions paddedTxts 29 | 30 | decrease :: Int -> [Int] 31 | decrease i = i : (decrease (i - 1)) 32 | 33 | applyToPairs :: (a -> b -> c -> c) -> c -> [(a, b)] -> c 34 | applyToPairs f c ps = foldl (\tm (a, b) -> f a b tm) c ps 35 | 36 | drawSidebarBG :: TileImage -> System' TileImage 37 | drawSidebarBG (TileImage arr) = return $ TileImage $ arr // bg 38 | where bg = fill black $ rect (V2 (xMax - sidebarSize + 1) 0) sidebarSize mapHeightInt 39 | 40 | drawShoppingListBG :: TileImage -> System' TileImage 41 | drawShoppingListBG (TileImage arr) = return $ TileImage $ arr // bg 42 | where bg = fill (V3 255 102 102) $ rect (V2 (xMax - sidebarSize + 1 + 1) 1) (sidebarSize - 2) (mapHeightInt - 2) 43 | 44 | drawShoppingListHeader :: TileImage -> System' TileImage 45 | drawShoppingListHeader tm = return $ drawText (V2 shoppingListContentsX shoppingListHeaderY) shoppingListHeader tm 46 | where shoppingListHeader = FGText "Shopping List" black 47 | 48 | drawInventoryHeader :: TileImage -> System' TileImage 49 | drawInventoryHeader tm = do 50 | flip cfoldM tm $ \tm (CPlayer, CInventory items, CShoppingList shoppingList) -> do 51 | let shoppingListLen = length shoppingList 52 | let inventoryHeader = FGText ("Cart") black 53 | return $ drawText (V2 shoppingListContentsX (inventoryHeaderY shoppingListLen)) inventoryHeader tm 54 | 55 | shoppingListHeaderY = 2 56 | shoppingListContentsX = xMax - sidebarSize + 3 57 | shoppingListContentsY = shoppingListHeaderY + 2 58 | inventoryHeaderY shoppingListLen = shoppingListContentsY + shoppingListLen + 2 59 | inventoryContentsY shoppingListLen = inventoryHeaderY shoppingListLen + 2 60 | 61 | drawInventoryContent :: TileImage -> System' TileImage 62 | drawInventoryContent tm = 63 | flip cfoldM tm $ \tm (CPlayer, CInventory inventory, CShoppingList shoppingList) -> do 64 | let shoppingListLen = length shoppingList 65 | let inventoryY = inventoryContentsY shoppingListLen 66 | let shoppingListPositions = [(V2 shoppingListContentsX y) | y <- [inventoryY ..]] 67 | return $ applyToPairs drawItemFullColor tm $ zip shoppingListPositions $ reverse inventory 68 | 69 | drawShoppingListContent :: TileImage -> System' TileImage 70 | drawShoppingListContent tm = 71 | flip cfoldM tm $ \tm (CPlayer, CShoppingList shoppingList, CInventory inventory) -> do 72 | let notInInventory = shoppingList \\ inventory 73 | let inInventory = shoppingList \\ notInInventory 74 | let shoppingListPositions = [(V2 shoppingListContentsX y) | y <- [shoppingListContentsY ..]] 75 | return $ applyToPairs drawItem tm $ zip shoppingListPositions $ (zip notInInventory (repeat False)) ++ (zip inInventory (repeat True)) 76 | 77 | rect :: Position -> Int -> Int -> [Position] 78 | rect (V2 sx sy) w h = [(V2 x y) | x <- [sx..(sx + w - 1)], y <- [sy .. (sy + h - 1)]] 79 | 80 | fill :: Color -> [Position] -> [(Position, Tile)] 81 | fill c ps = map (\p -> (p, Tile filledGlyph c c)) ps 82 | 83 | drawItem :: Position -> (Item, Bool) -> TileImage -> TileImage 84 | drawItem pos (item, True) = drawItemInInventory pos item 85 | drawItem pos (item, False) = drawItemFullColor pos item 86 | 87 | whiteTerminalText :: String -> TerminalText 88 | whiteTerminalText s = FGText s white 89 | 90 | itemTerminalText :: Item -> TerminalText 91 | itemTerminalText i = itemTextStyle i $ show i 92 | 93 | itemTextStyle :: Item -> String -> TerminalText 94 | itemTextStyle item t = txt 95 | where 96 | txt = Icon itemDrawable <> toText (" " ++ t) 97 | itemDrawable = lookupItemDrawable item 98 | toText t = case itemDrawable of 99 | (Drawable _ fg) -> FGText t fg 100 | (DrawableBG _ fg bg) -> BGText t fg bg 101 | 102 | drawItemFullColor :: Position -> Item -> TileImage -> TileImage 103 | drawItemFullColor pos item = drawText pos txt 104 | where 105 | txt = Icon itemDrawable <> toText (" " ++ itemTxt) 106 | itemTxt = rightPad (sidebarSize - 4 - 2) ' ' $ show item 107 | itemDrawable = lookupItemDrawable item 108 | toText t = case itemDrawable of 109 | (Drawable _ fg) -> FGText t fg 110 | (DrawableBG _ fg bg) -> BGText t fg bg 111 | 112 | drawItemInInventory :: Position -> Item -> TileImage -> TileImage 113 | drawItemInInventory pos item = drawText pos txt 114 | where 115 | txt = Icon itemDrawable <> toText (" " ++ itemTxt) <> FGText "X" grey 116 | itemTxt = rightPad (sidebarSize - 4 - 2 - 1) ' ' $ show item 117 | toText t = FGText t grey 118 | itemDrawable = Drawable itemGlyph grey 119 | itemGlyph = case lookupItemDrawable item of 120 | (Drawable g _) -> g 121 | (DrawableBG g _ _) -> g 122 | 123 | leftPad :: Int -> a -> [a] -> [a] 124 | leftPad m x xs = replicate (m - length xs) x ++ xs 125 | 126 | rightPad :: Int -> a -> [a] -> [a] 127 | rightPad m x xs = take m $ xs ++ repeat x 128 | 129 | drawUI :: TileImage -> System' TileImage 130 | drawUI tm = 131 | drawSidebarBG tm 132 | >>= drawShoppingListBG 133 | >>= drawShoppingListHeader 134 | >>= drawShoppingListContent 135 | >>= drawInventoryHeader 136 | >>= drawInventoryContent 137 | >>= drawLog -------------------------------------------------------------------------------- /app/Renderer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Renderer where 4 | 5 | import Control.Monad 6 | import Foreign.C.Types 7 | import SDL.Vect 8 | import SDL (($=)) 9 | import qualified SDL 10 | import Data.Array ((!)) 11 | import qualified Data.Array as Array 12 | import Position 13 | import Apecs hiding (($=)) 14 | import Control.Concurrent 15 | 16 | import TileImage 17 | import TileMap 18 | import Colors 19 | 20 | screenWidth, screenHeight :: CInt 21 | (screenWidth, screenHeight) = (mapWidth * tileSize, mapHeight * tileSize) 22 | 23 | data Texture = Texture SDL.Texture (V2 CInt) 24 | 25 | createBlank :: SDL.Renderer -> V2 CInt -> SDL.TextureAccess -> IO Texture 26 | createBlank r size access = Texture <$> SDL.createTexture r SDL.RGBA8888 access size <*> pure size 27 | 28 | setAsRenderTarget :: SDL.Renderer -> Maybe Texture -> IO () 29 | setAsRenderTarget r Nothing = SDL.rendererRenderTarget r $= Nothing 30 | setAsRenderTarget r (Just (Texture t _)) = SDL.rendererRenderTarget r $= Just t 31 | 32 | loadTexture :: SDL.Renderer -> FilePath -> IO Texture 33 | loadTexture r filePath = do 34 | surface <- SDL.loadBMP filePath 35 | size <- SDL.surfaceDimensions surface 36 | t <- SDL.createTextureFromSurface r surface 37 | SDL.freeSurface surface 38 | return (Texture t size) 39 | 40 | renderTileMap :: SDL.Renderer -> Texture -> TileImage -> TileImage -> IO () 41 | renderTileMap r t (TileImage previous) (TileImage arr) = mapM st (Array.range (Array.bounds arr)) >> return () 42 | where st pos = do 43 | let tileOld = previous ! pos 44 | let tileNew = arr ! pos 45 | unless (tileOld == tileNew) $ do 46 | renderTile r t pos tileNew 47 | 48 | setTextureColor :: Texture -> Color -> IO () 49 | setTextureColor (Texture t _) color = SDL.textureColorMod t $= color 50 | 51 | spriteSize :: V2 CInt 52 | spriteSize = V2 (fromIntegral tileSize) (fromIntegral tileSize) 53 | 54 | renderTile :: SDL.Renderer -> Texture -> Position -> Tile -> IO () 55 | renderTile r t pos (Tile glyph fgColor bgColor) = do 56 | let point = P $ fmap (*tileSize) $ fmap fromIntegral pos 57 | let renderGlyph g = renderTexture r t point $ Just $ SDL.Rectangle (P (fmap (*tileSize) g)) spriteSize 58 | setTextureColor t bgColor 59 | renderGlyph filledGlyph 60 | setTextureColor t fgColor 61 | renderGlyph glyph 62 | 63 | tileSize, textureWidth, textureHeight :: CInt 64 | tileSize = 12 65 | textureWidth = mapWidth * tileSize 66 | textureHeight = mapHeight * tileSize 67 | 68 | renderTexture :: SDL.Renderer -> Texture -> Point V2 CInt -> Maybe (SDL.Rectangle CInt) -> IO () 69 | renderTexture r (Texture t size) xy clip = 70 | let dstSize = maybe size (\(SDL.Rectangle _ size') -> size') clip 71 | in SDL.copy r t clip (Just (SDL.Rectangle xy dstSize)) 72 | 73 | setTextureBlendMode :: Texture -> SDL.BlendMode -> IO () 74 | setTextureBlendMode (Texture t _) bm = SDL.textureBlendMode t $= bm 75 | 76 | play 77 | :: w 78 | -> System w TileImage -- ^ Drawing function 79 | -> (SDL.EventPayload -> System w ()) -- ^ Event handling function 80 | -> (Float -> System w Bool) -- ^ Stepping function, with a time delta argument. 81 | -> IO () 82 | play initialWorld draw handle step = do 83 | 84 | -- init and show window 85 | SDL.initialize [SDL.InitVideo] 86 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 87 | renderQuality <- SDL.get SDL.HintRenderScaleQuality 88 | when (renderQuality /= SDL.ScaleLinear) $ putStrLn "Warning: Linear texture filtering not enabled!" 89 | window <- SDL.createWindow "mallRL" SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 90 | SDL.showWindow window 91 | 92 | -- init and show renderer 93 | let rendererConfig = SDL.RendererConfig { SDL.rendererType = SDL.AcceleratedVSyncRenderer, SDL.rendererTargetTexture = False} 94 | renderer <- SDL.createRenderer window (-1) rendererConfig 95 | 96 | targetTexture <- createBlank renderer (V2 textureWidth textureHeight) SDL.TextureAccessTarget 97 | spriteSheetTexture <- loadTexture renderer "resources/font_custom.bmp" 98 | 99 | let loop world previousImage = do 100 | 101 | -- handle events 102 | events <- SDL.pollEvents 103 | let eventPayloads = map SDL.eventPayload events 104 | let quit = elem SDL.QuitEvent $ eventPayloads 105 | let handle' w evt = runWith w $ handle evt >> ask 106 | worldAfterEvents <- foldM handle' world eventPayloads 107 | 108 | -- step world 109 | let t = 0.1 110 | (worldAfterStepping, rerenderNecessary) <- runWith worldAfterEvents $ do 111 | rerenderNecessary <- step t 112 | worldAfterStepping <- ask 113 | return (worldAfterStepping, rerenderNecessary) 114 | 115 | nextImage <- if rerenderNecessary 116 | then do 117 | -- render map to texture 118 | tileImage <- runWith worldAfterStepping draw 119 | setAsRenderTarget renderer (Just targetTexture) 120 | renderTileMap renderer spriteSheetTexture previousImage tileImage 121 | return tileImage 122 | else return previousImage 123 | 124 | -- render texture to screen 125 | setAsRenderTarget renderer Nothing 126 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 127 | SDL.clear renderer 128 | let renderPosition = P (V2 0 0) 129 | renderTexture renderer targetTexture renderPosition Nothing 130 | SDL.present renderer 131 | 132 | -- sleep 133 | Control.Concurrent.threadDelay 16000 -- 33333 134 | 135 | --repeat 136 | unless quit $ loop worldAfterStepping nextImage 137 | 138 | loop initialWorld emptyMap 139 | 140 | SDL.destroyRenderer renderer 141 | SDL.destroyWindow window 142 | SDL.quit 143 | 144 | emptyMap :: TileImage 145 | emptyMap = TileImage $ Array.listArray arrayBounds $ cycle [tileEmpty] -------------------------------------------------------------------------------- /app/MapGeneration.hs: -------------------------------------------------------------------------------- 1 | module MapGeneration where 2 | import Control.Monad.Random 3 | import Apecs hiding (Map, Set) 4 | import Linear 5 | import Position 6 | import Colors 7 | import Item 8 | import World 9 | import Data.List 10 | import Room 11 | import Car 12 | import RandomUtility 13 | import CDrawable 14 | 15 | data ShelfType = ShelfHor | ShelfVer | ShelfSquare 16 | 17 | minRoomLen, minRoomSize :: Int 18 | minRoomLen = 10 19 | minRoomSize = 100 20 | 21 | initializeMap :: System' (Room, [CCar]) 22 | initializeMap = do 23 | (mallRoom, rooms, walls) <- lift $ evalRandIO $ createMall 40 3 24 | -- mkGround mallRoom 25 | cars1 <- mkParkingLot 10 5 5 26 | cars2 <- mkParkingLot 10 25 5 27 | cars3 <- mkParkingLot 10 45 5 28 | flip mapM_ (allGroundPositions rooms) $ \p -> do 29 | newEntity (CPosition p, dGround, CIsInRoom (getRoomsForPosition rooms p)) 30 | ds <- evalRandom $ do 31 | doors <- doorPositions rooms 32 | entrance <- entracePositions rooms 33 | return $ doors ++ entrance 34 | mapM_ (initializeWall ds) walls 35 | flip mapM_ rooms $ \r -> do 36 | shelfType <- evalRandom $ pickRandom [ShelfVer, ShelfHor] 37 | fillRoom shelfType r 38 | return (mallRoom, cars1 ++ cars2 ++ cars3) 39 | 40 | mkGround :: Room -> System' () 41 | mkGround (Room x y w h) = do 42 | let borderX = x + w + 5 43 | let allPositions = [V2 x y | x <- [0 .. borderX], y <- [0 .. positionMaxY]] 44 | flip mapM_ allPositions $ \p -> do 45 | newEntity (CPosition p, DrawableBG filledGlyph groundBGColor groundBGColor) 46 | 47 | leftWall, rightWall, upperWall, lowerWall :: Room -> [Position] 48 | leftWall (Room x y _ h) = [V2 (x - 1) ys | ys <- [y .. y + h - 1]] 49 | rightWall (Room x y w h) = [V2 (x + w) ys | ys <- [y .. y + h - 1]] 50 | upperWall (Room x y w _) = [V2 xs (y - 1) | xs <- [x .. x + w - 1]] 51 | lowerWall (Room x y w h) = [V2 xs (y + h) | xs <- [x .. x + w - 1]] 52 | 53 | doorPositions :: RandomGen g => [Room] -> Rand g [Position] 54 | doorPositions rooms = do 55 | let doorWalls = filter (\l -> length l >= doorSize) [checkNeighbours r1 r2 | r1 <- rooms, r2 <- rooms] 56 | concat <$> mapM pickDoor doorWalls 57 | 58 | entracePositions :: RandomGen g => [Room] -> Rand g [Position] 59 | entracePositions rooms = do 60 | outerLeftRoom <- pickRandom $ filter (isOuterLeftRoom rooms) rooms 61 | pickDoor $ leftWall outerLeftRoom 62 | 63 | isOuterLeftRoom :: [Room] -> Room -> Bool 64 | isOuterLeftRoom rs rLeft = null $ concatMap (\rRight -> intersect (leftWall rLeft) (rightWall rRight)) rs 65 | 66 | isOuterRightRoom :: [Room] -> Room -> Bool 67 | isOuterRightRoom rs r = null $ concatMap (\r -> intersect (rightWall r) (leftWall r)) rs 68 | 69 | checkNeighbours :: Room -> Room -> [Position] 70 | checkNeighbours r1 r2 = 71 | let l = intersect (leftWall r1) (rightWall r2) 72 | u = intersect (upperWall r1) (lowerWall r2) 73 | in l ++ u 74 | 75 | doorSize = 3 76 | 77 | pickDoor :: RandomGen g => [Position] -> Rand g [Position] 78 | pickDoor ps = do 79 | start <- getRandomR (0, length ps - 1 - doorSize) 80 | return $ take doorSize $ drop start ps 81 | 82 | getRoomsForPosition :: [Room] -> Position -> [Room] 83 | getRoomsForPosition rs p = filter (containsPosition p) rs 84 | 85 | initializeWall :: [Position] -> Wall -> System' () 86 | initializeWall doors (Wall x y x2 y2) = do 87 | let positions = filter (\p -> not (elem p doors)) [(V2 wx wy) | wx <- [x .. x2], wy <- [y .. y2]] 88 | flip mapM_ positions $ \p -> do 89 | newEntity (CSolid, CPosition p, dWall) 90 | return () 91 | 92 | createMall :: RandomGen g => Int -> Int -> Rand g (Room, [Room], [Wall]) 93 | createMall x y = do 94 | initialW <- getRandomR (30,50) 95 | initialH <- getRandomR (30,50) 96 | let wW = initialW + 1 97 | let wH = initialH + 1 98 | let wTop = Wall x y (x + wW) y 99 | let wBot = Wall x (y + wH) (x + wW) (y + wH) 100 | let wLeft = Wall x y x (y + wH) 101 | let wRight = Wall (x + wW) y (x + wW) (y + wH) 102 | let initialRoom = Room (x+1) (y+1) initialW initialH 103 | (rooms, walls) <- divideRoom initialRoom 104 | return (initialRoom, rooms, walls ++ [wTop, wBot, wLeft, wRight]) 105 | 106 | divideRoom :: RandomGen g => Room -> Rand g ([Room], [Wall]) 107 | divideRoom room = do 108 | divRes <- divide room 109 | case divRes of 110 | Just (wall, room1, room2) -> do 111 | (room1s, wall1s) <- divideRoom room1 112 | (room2s, wall2s) <- divideRoom room2 113 | return (room1s ++ room2s, [wall] ++ wall1s ++ wall2s) 114 | Nothing -> return ([room],[]) 115 | 116 | divide :: RandomGen g => Room -> Rand g (Maybe (Wall, Room, Room)) 117 | divide (Room x y w h) = chanceForNothing 0 $ do 118 | divHor <- getRandomR (0, 1) 119 | variance <- getRandomR (-3, 3) 120 | let fw = fromIntegral w :: Float 121 | let fh = fromIntegral h :: Float 122 | if divHor >= (fw / (fw + fh)) 123 | then do -- [|] 124 | let h1 = div h 2 + variance 125 | let h2 = h - h1 - 1 126 | let wall = Wall x (y + h1) (x + w - 1) (y + h1) 127 | return $ do 128 | room1 <- constructRoom x y w h1 129 | room2 <- constructRoom x (y + h1 + 1) w h2 130 | return (wall, room1, room2) 131 | else do -- [-] 132 | let w1 = div w 2 + variance 133 | let w2 = w - w1 - 1 134 | let wall = Wall (x + w1) y (x + w1) (y + h - 1) 135 | return $ do 136 | room1 <- constructRoom x y w1 h 137 | room2 <- constructRoom (x + w1 + 1) y w2 h 138 | return (wall, room1, room2) 139 | 140 | constructRoom :: Int -> Int -> Int -> Int -> Maybe Room 141 | constructRoom x y w h = if valid then Just (Room x y w h) else Nothing 142 | where valid = w * h >= minRoomSize && w >= minRoomLen && h >= minRoomLen 143 | 144 | 145 | chanceForNothing :: RandomGen g => Float -> Rand g (Maybe a) -> Rand g (Maybe a) 146 | chanceForNothing c r = do 147 | b <- chance c 148 | if b then return Nothing else r 149 | 150 | chance :: RandomGen g => Float -> Rand g Bool 151 | chance f = do 152 | r <- getRandomR (0,100) 153 | return $ r < f 154 | 155 | type ItemChooser = Direction -> Rand StdGen Item 156 | 157 | alwaysNacho :: ItemChooser 158 | alwaysNacho _ = return Nachos 159 | 160 | dirItemChooser :: Item -> Item -> Item -> Item -> ItemChooser 161 | dirItemChooser l _ _ _ DirLeft = return l 162 | dirItemChooser _ r _ _ DirRight = return r 163 | dirItemChooser _ _ u _ DirUp = return u 164 | dirItemChooser _ _ _ d DirDown = return d 165 | 166 | randomItemChooser :: ItemChooser 167 | randomItemChooser _ = pickRandom allItems 168 | 169 | mkShelfVer :: Position -> ItemChooser -> System' () 170 | mkShelfVer (V2 x' y) itemChooser = do 171 | let x = x' + 1 172 | let l = shelfTypeHeight ShelfVer 173 | flip mapM_ [V2 x ys | ys <- [y + 1 .. y + l - 2] ] $ \p -> do 174 | -- shelf middle 175 | newEntity (CSolid, CPosition p, dWall) 176 | 177 | -- shelf left 178 | leftItem <- lift $ evalRandIO (itemChooser DirLeft) 179 | newEntity (CSolid, CPosition (left p), dShelf) 180 | newEntity (CItem leftItem, CPosition (left p), lookupItemDrawable leftItem) 181 | 182 | -- shelf right 183 | rightItem <- lift $ evalRandIO (itemChooser DirRight) 184 | newEntity (CSolid, CPosition (right p), dShelf) 185 | newEntity (CItem rightItem, CPosition (right p), lookupItemDrawable rightItem) 186 | 187 | flip mapM_ [V2 xs y | xs <- [x - 1 .. x + 1] ] $ \p -> do 188 | -- shelf north bound 189 | newEntity (CSolid, CPosition p, dShelfNorth) 190 | 191 | flip mapM_ [V2 xs (y + l - 1) | xs <- [x - 1 .. x + 1] ] $ \p -> do 192 | -- shelf south bound 193 | newEntity (CSolid, CPosition p, dShelfSouth) 194 | 195 | mkShelfHor :: Position -> ItemChooser -> System' () 196 | mkShelfHor (V2 x y') itemChooser = do 197 | let y = y' + 1 198 | let l = shelfTypeWidth ShelfHor 199 | flip mapM_ [V2 xs y | xs <- [x + 1 .. x + l - 2] ] $ \p -> do 200 | -- shelf middle 201 | newEntity (CSolid, CPosition p, dWall) 202 | 203 | -- shelf up 204 | leftItem <- lift $ evalRandIO (itemChooser DirLeft) 205 | newEntity (CSolid, CPosition (up p), dShelf) 206 | newEntity (CItem leftItem, CPosition (up p), lookupItemDrawable leftItem) 207 | 208 | -- shelf down 209 | rightItem <- lift $ evalRandIO (itemChooser DirRight) 210 | newEntity (CSolid, CPosition (down p), dShelf) 211 | newEntity (CItem rightItem, CPosition (down p), lookupItemDrawable rightItem) 212 | 213 | flip mapM_ [V2 x ys | ys <- [y - 1 .. y + 1] ] $ \p -> do 214 | -- shelf west bound 215 | newEntity (CSolid, CPosition p, dShelfWest) 216 | 217 | flip mapM_ [V2 (x + l - 1) ys | ys <- [y - 1 .. y + 1] ] $ \p -> do 218 | -- shelf east bound 219 | newEntity (CSolid, CPosition p, dShelfEast) 220 | 221 | 222 | pickItemChooser :: RandomGen g => Rand g ItemChooser 223 | pickItemChooser = do 224 | l <- pickRandom allItems 225 | r <- pickRandom allItems 226 | u <- pickRandom allItems 227 | d <- pickRandom allItems 228 | pickRandom [dirItemChooser l r u d, randomItemChooser] 229 | 230 | fillRoom :: ShelfType -> Room -> System' () 231 | fillRoom st (Room x y w h) = do 232 | let sp = shelfTypePadding st 233 | let sw = shelfTypeWidth st 234 | let sh = shelfTypeHeight st 235 | let horNumShelves = (w - sp) `div` (sp + sw) 236 | let xOff = (w - (sp + horNumShelves * (sp + sw))) `div` 2 237 | let verNumShelves = (h - sp) `div` (sp + sh) 238 | let yOff = (h - (sp + verNumShelves * (sp + sh))) `div` 2 239 | let shelfPositions = [(V2 (x + xOff + sp + ix * (sw + sp)) (y + yOff + sp + iy * (sh + sp))) | ix <- [0..horNumShelves - 1], iy <- [0..verNumShelves - 1]] 240 | flip mapM_ shelfPositions $ \p -> do 241 | chooser <- evalRandom pickItemChooser 242 | shelfGen st p chooser 243 | 244 | shelfTypeWidth, shelfTypeHeight, shelfTypePadding :: ShelfType -> Int 245 | shelfTypeWidth ShelfVer = 3 246 | shelfTypeWidth ShelfHor = 7 247 | shelfTypeHeight ShelfVer = 7 248 | shelfTypeHeight ShelfHor = 3 249 | shelfTypePadding ShelfVer = 2 250 | shelfTypePadding ShelfHor = 2 251 | 252 | shelfGen ShelfVer = mkShelfVer 253 | shelfGen ShelfHor = mkShelfHor 254 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Apecs hiding (Map, Set) 3 | import Linear 4 | import Position 5 | import Renderer 6 | import qualified SDL 7 | import Colors 8 | import CDrawable 9 | import Item 10 | import World 11 | import Interaction 12 | import TerminalText 13 | import MapGeneration 14 | import Pathfinding 15 | import Draw 16 | import Control.Monad 17 | import Data.Maybe 18 | import RandomUtility 19 | import Room 20 | import Data.List 21 | import Control.Monad.Random 22 | import UI 23 | 24 | main :: IO () 25 | main = do 26 | w <- initWorld 27 | runWith w $ do 28 | initialize 29 | wNew <- ask 30 | lift $ play wNew draw handleEvent step 31 | 32 | initialize :: System' () 33 | initialize = do 34 | names <- lift $ lines <$> readFile "resources/names.txt" 35 | set global $ Running 0 36 | set global $ CLog [] 37 | welcomeMessage 38 | (mallRoom, carComponents) <- initializeMap 39 | set global $ CMallRoom mallRoom 40 | mkBorder mallRoom 41 | 42 | (CCar playerCarPosition) <- evalRandom $ pickRandom carComponents 43 | let playerPosition = right $ carDoorPosition playerCarPosition 44 | playerShoppingList <- evalRandom $ sort <$> randomShoppingList 10 45 | newEntity (CPlayer, CPosition playerPosition, CSolid, CInventory [], CName "You", CShoppingList playerShoppingList, (CIsInRoom [], COwnsCar playerCarPosition)) 46 | 47 | flip mapM_ carComponents $ \(CCar carPosition) -> do 48 | when (carPosition /= playerCarPosition) $ do 49 | npcName <- evalRandom $ pickRandom names 50 | let npcGlyph = charToGlyph $ head npcName 51 | npcShoppingList <- evalRandom $ randomShoppingList 10 52 | let npcPosition = right $ carDoorPosition carPosition 53 | newEntity (CBehaviour Deciding, CPosition npcPosition, Drawable npcGlyph npcColor, CSolid, CInventory [], CShoppingList npcShoppingList, CName npcName, COwnsCar carPosition) 54 | return () 55 | 56 | modify global $ appendAction Redisplay 57 | return () 58 | 59 | handleEvent :: SDL.EventPayload -> System' () 60 | handleEvent e = do 61 | whenGameIsRunning $ do 62 | -- arrow keys 63 | whenKeyPressed SDL.ScancodeRight e $ modify global $ appendAction $ Move DirRight 64 | whenKeyPressed SDL.ScancodeLeft e $ modify global $ appendAction $ Move DirLeft 65 | whenKeyPressed SDL.ScancodeUp e $ modify global $ appendAction $ Move DirUp 66 | whenKeyPressed SDL.ScancodeDown e $ modify global $ appendAction $ Move DirDown 67 | 68 | -- wasd 69 | whenKeyPressed SDL.ScancodeD e $ modify global $ appendAction $ Move DirRight 70 | whenKeyPressed SDL.ScancodeA e $ modify global $ appendAction $ Move DirLeft 71 | whenKeyPressed SDL.ScancodeW e $ modify global $ appendAction $ Move DirUp 72 | whenKeyPressed SDL.ScancodeS e $ modify global $ appendAction $ Move DirDown 73 | 74 | -- reset 75 | whenKeyPressed SDL.ScancodeR e $ do 76 | cmapM_ $ \(CPosition p, Entity e) -> destroyEntity (Entity e) 77 | initialize 78 | 79 | step :: Float -> System' Bool 80 | step _ = do 81 | action <- pollAction 82 | case action of 83 | (Just a) -> do 84 | handleAction a 85 | turn 86 | updatePlayerColor 87 | return True 88 | Nothing -> return False 89 | 90 | randomShoppingList :: RandomGen g => Int -> Rand g [Item] 91 | randomShoppingList 0 = return [] 92 | randomShoppingList n = do 93 | i <- pickRandom allItems 94 | is <- randomShoppingList $ n - 1 95 | return $ i : is 96 | 97 | carDoorPosition :: Position -> Position 98 | carDoorPosition carPosition = carPosition + V2 2 4 99 | 100 | mkBorder :: Room -> System' () 101 | mkBorder (Room x y w h) = do 102 | let borderX = x + w + 5 103 | let allPositions = [V2 x y | x <- [0 .. borderX], y <- [0 .. positionMaxY]] 104 | let edgePositions = filter (\(V2 x y) -> x == 0 || y == 0 || x == borderX || y == positionMaxY) allPositions 105 | flip mapM_ edgePositions $ \p -> newEntity (CSolid, CPosition p, Drawable (charToGlyph '#') white) 106 | 107 | updatePlayerColor :: System' () 108 | updatePlayerColor = do 109 | (CMallRoom mallRoom) <- get global 110 | cmap $ \(CPlayer, CPosition pos) -> if (containsPosition pos mallRoom) 111 | then dPlayerIndoors 112 | else dPlayerOutdoors 113 | 114 | handleAction :: Action -> System' () 115 | handleAction (Move d) = cmapM (movePlayer d) 116 | handleAction _ = return () 117 | 118 | whenGameIsRunning :: System' () -> System' () 119 | whenGameIsRunning s = do 120 | isRunning <- (/= Stopped) <$> get global 121 | when isRunning s 122 | 123 | increaseTurnCounter :: CGameState -> CGameState 124 | increaseTurnCounter (Running x) = Running $ x + 1 125 | increaseTurnCounter Stopped = Stopped 126 | 127 | turn :: System' () 128 | turn = whenGameIsRunning $ do 129 | stepAI 130 | checkForSoldOutItems 131 | modify global increaseTurnCounter 132 | 133 | stepAI :: System' () 134 | stepAI = cmapM $ \ (CPosition position, CBehaviour behaviour, CShoppingList toBuy, e) -> CBehaviour <$> 135 | case behaviour of 136 | (Buy item []) -> return Deciding -- This should never happen 137 | currentBehaviour@(Buy item path@(nextStep : nextSteps)) -> do 138 | let targetPosition = last path 139 | itemStillThere <- isItemOnPosition item targetPosition 140 | if itemStillThere then do 141 | ((CPosition movedPosition), pickedupItems) <- moveTo position nextStep e 142 | set e (CPosition movedPosition) 143 | if item `elem` pickedupItems 144 | then return Deciding -- Succesfully bought item 145 | else if movedPosition == position 146 | then do -- Path is blocked, recalculate 147 | recalculate <- evalRandom $ chance 10 148 | if recalculate then do 149 | maybePath <- pathToPosition position targetPosition 150 | return $ case maybePath of 151 | (Just path) -> Buy item path 152 | Nothing -> currentBehaviour 153 | else return currentBehaviour 154 | else return $ Buy item nextSteps 155 | else return Deciding -- Item is gone 156 | Deciding -> do 157 | itemToBuy <- evalRandom $ pickRandom toBuy 158 | itemLocations <- itemPositions itemToBuy 159 | if null itemLocations 160 | then return Deciding 161 | else do 162 | selectedLocation <- evalRandom $ pickRandom itemLocations 163 | maybePath <- pathToPosition position selectedLocation 164 | return $ case maybePath of 165 | (Just path) -> Buy itemToBuy path 166 | Nothing -> Deciding 167 | 168 | logTxtS :: String -> System' () 169 | logTxtS s = logTxt $ FGText s white 170 | 171 | pollAction :: System' (Maybe Action) 172 | pollAction = do 173 | actions <- get global 174 | case actions of 175 | (CActions []) -> return Nothing 176 | (CActions (a:as)) -> do 177 | set global $ CActions as 178 | return $ Just a 179 | 180 | movePlayer :: Direction -> (CPlayer, CPosition, Entity) -> System' CPosition 181 | movePlayer d (_, (CPosition p), e) = move (dirToFun d) p e 182 | 183 | dirToFun :: Direction -> (Position -> Position) 184 | dirToFun DirLeft = left 185 | dirToFun DirRight = right 186 | dirToFun DirUp = up 187 | dirToFun DirDown = down 188 | 189 | appendAction :: Action -> CActions -> CActions 190 | appendAction a (CActions as) = CActions $ as ++ [a] 191 | 192 | move :: (Position -> Position) -> Position -> Entity -> System' CPosition 193 | move direction p e = fst <$> moveTo p (direction p) e 194 | 195 | moveTo :: Position -> Position -> Entity -> System' (CPosition, [Item]) 196 | moveTo source target movingEntity = do 197 | entitiesAtTarget <- entitiesAtPosition target 198 | pickedupItems <- catMaybes <$> mapM (pickupItem movingEntity) entitiesAtTarget 199 | mapM (enterCar movingEntity) entitiesAtTarget 200 | mapM (bumpIntoNPC movingEntity) entitiesAtTarget 201 | targetBlocked <- containsSolidEntity entitiesAtTarget 202 | when (not targetBlocked) $ mapM_ (enterRooms movingEntity) entitiesAtTarget 203 | let newPos = CPosition $ if targetBlocked then source else target 204 | return (newPos, pickedupItems) 205 | 206 | phrases :: [String] 207 | phrases = 208 | [ "Nice to meet you." 209 | , "I love shopping for groceries." 210 | , "Watch your step." 211 | ] 212 | 213 | bumpIntoNPC :: Entity -> Entity -> System' () 214 | bumpIntoNPC playerEntity npcEntity = do 215 | interaction_ playerEntity npcEntity $ \(CPlayer) (CBehaviour b, CName n) -> do 216 | phrase <- evalRandom $ pickRandom phrases 217 | logTxt $ FGText (n ++ ": ") (V3 255 255 0) <> whiteTerminalText phrase 218 | 219 | 220 | enterCar :: Entity -> Entity -> System' () 221 | enterCar playerEntity itemEntity = do 222 | interaction_ playerEntity itemEntity $ \(CPlayer, COwnsCar ownedCarPosition, CInventory inventory, CShoppingList sl) (CCar carPosition, CPosition touchedPosition) -> do 223 | let allItemsBought = null $ sl \\ inventory 224 | when allItemsBought $ 225 | if ownedCarPosition /= carPosition 226 | then logTxtS "This is not your car." 227 | else if touchedPosition == carDoorPosition carPosition 228 | then win 229 | else logTxtS "Go to the driver's door." 230 | 231 | win :: System' () 232 | win = do 233 | gameState <- get global 234 | let turns = case gameState of 235 | (Running t) -> show t 236 | _ -> "?" 237 | let text = "You won after " ++ turns ++ " turns! Press [r] to restart." 238 | logTxt $ FGText text (V3 100 255 100) 239 | set global Stopped 240 | 241 | checkForSoldOutItems :: System' () 242 | checkForSoldOutItems = cmapM_ $ \(CPlayer, CShoppingList sl, CInventory inventory) -> do 243 | let itemsNotBought = nub $ sl \\ inventory 244 | soldOutItemsNotBought <- filterM isItemSoldOut itemsNotBought 245 | case soldOutItemsNotBought of 246 | (i : _) -> looseItemSoldOut i 247 | _ -> return () 248 | 249 | pickupItem :: Entity -> Entity -> System' (Maybe Item) 250 | pickupItem activeEntity itemEntity = do 251 | interaction activeEntity itemEntity $ \(CInventory currentInventory, CName name, CShoppingList sl) (CItem i) -> do 252 | let newInventory = i : currentInventory 253 | set activeEntity $ CInventory newInventory 254 | isPlayer <- exists activeEntity (Proxy :: Proxy CPlayer) 255 | when isPlayer $ do 256 | logTxt $ whiteTerminalText "You picked up " <> itemTerminalText i 257 | let allItemsBought = null $ sl \\ newInventory 258 | if allItemsBought 259 | then logTxtS "You got everything you need. Go to your car now." 260 | else if length newInventory >= (length sl) + shoppingListBuffer 261 | then looseFullInventory 262 | else return () 263 | destroyEntity itemEntity 264 | return i 265 | 266 | looseFullInventory :: System' () 267 | looseFullInventory = logTxtS "You bought way too much!" >> loose 268 | 269 | looseItemSoldOut :: Item -> System' () 270 | looseItemSoldOut i = do 271 | logTxt $ whiteTerminalText "The article " <> itemTerminalText i <> whiteTerminalText " is sold out!" 272 | loose 273 | 274 | loose :: System' () 275 | loose = do 276 | logTxt $ FGText "You loose. Press [r] to restart." (V3 255 0 0) 277 | set global Stopped 278 | 279 | enterRooms :: Entity -> Entity -> System' () 280 | enterRooms playerEntity itemEntity = interaction_ playerEntity itemEntity $ 281 | \(CPlayer) rooms@(CIsInRoom _) -> set playerEntity rooms 282 | 283 | whenKeyPressed :: SDL.Scancode -> SDL.EventPayload -> System' () -> System' () 284 | whenKeyPressed s e sys = if (isKeyPressed s e) then sys else return () 285 | 286 | isKeyPressed :: SDL.Scancode -> SDL.EventPayload -> Bool 287 | isKeyPressed scancode (SDL.KeyboardEvent e) = pressed && justPressed && rightKey 288 | where 289 | pressed = SDL.keyboardEventKeyMotion e == SDL.Pressed 290 | justPressed = SDL.keyboardEventRepeat e == False 291 | rightKey = scancode == (SDL.keysymScancode (SDL.keyboardEventKeysym e )) 292 | isKeyPressed _ _ = False 293 | 294 | 295 | logTxt :: TerminalText -> System' () 296 | logTxt txt = modify global $ \(CLog txts) -> CLog $ txt : txts 297 | 298 | welcomeMessage :: System' () 299 | welcomeMessage = do 300 | logTxt $ FGText "Welcome to mallRL, a 7drl game by Nikolas Maehlmann." (V3 100 100 255) 301 | logTxtS $ "You are [@]. Use arrow keys or [w,a,s,d] to move. [r] to restart." 302 | logTxtS $ "Have fun shopping!" --------------------------------------------------------------------------------