├── .gitignore ├── Setup.hs ├── sprites.png ├── examples ├── 01-noise.png ├── 04-cave.png ├── 05-cave.png ├── 06-cave.gif ├── 02-annealing.png ├── 03-clustering.png ├── 07-mountains.png └── 08-isometric.gif ├── isometric-tiles ├── dirt.png ├── endE.png ├── endN.png ├── endS.png ├── endW.png ├── lotE.png ├── lotN.png ├── lotS.png ├── lotW.png ├── road.png ├── beach.png ├── beachE.png ├── beachN.png ├── beachS.png ├── beachW.png ├── exitE.png ├── exitN.png ├── exitS.png ├── exitW.png ├── grass.png ├── hillE.png ├── hillES.png ├── hillN.png ├── hillNE.png ├── hillNW.png ├── hillS.png ├── hillSW.png ├── hillW.png ├── lotES.png ├── lotNE.png ├── lotNW.png ├── lotSW.png ├── roadES.png ├── roadEW.png ├── roadNE.png ├── roadNS.png ├── roadNW.png ├── roadSW.png ├── water.png ├── waterE.png ├── waterN.png ├── waterS.png ├── waterW.png ├── beachES.png ├── beachNE.png ├── beachNW.png ├── beachSW.png ├── bridgeEW.png ├── bridgeNS.png ├── crossroad.png ├── riverES.png ├── riverEW.png ├── riverNE.png ├── riverNS.png ├── riverNW.png ├── riverSW.png ├── roadHillE.png ├── roadHillN.png ├── roadHillS.png ├── roadHillW.png ├── treeShort.png ├── treeTall.png ├── waterES.png ├── waterNE.png ├── waterNW.png ├── waterSW.png ├── coniferTall.png ├── dirtDouble.png ├── grassWhole.png ├── roadHill2E.png ├── roadHill2N.png ├── roadHill2S.png ├── roadHill2W.png ├── treeAltTall.png ├── beachCornerES.png ├── beachCornerNE.png ├── beachCornerNW.png ├── beachCornerSW.png ├── coniferAltTall.png ├── coniferShort.png ├── crossroadESW.png ├── crossroadNES.png ├── crossroadNEW.png ├── crossroadNSW.png ├── riverBankedES.png ├── riverBankedEW.png ├── riverBankedNE.png ├── riverBankedNS.png ├── riverBankedNW.png ├── riverBankedSW.png ├── treeAltShort.png ├── waterCornerES.png ├── waterCornerNE.png ├── waterCornerNW.png ├── waterCornerSW.png └── coniferAltShort.png ├── src ├── Map.hs ├── Generator.hs ├── Data │ ├── Nat │ │ └── Extra.hs │ └── Vect.hs ├── Render.hs ├── Map │ ├── Coordinate.hs │ ├── Kernel.hs │ ├── Slice.hs │ └── Type.hs ├── Generator │ ├── Noise.hs │ ├── Smoother.hs │ └── WaveFunctionCollapse.hs └── Render │ ├── Pixels.hs │ ├── Isometric.hs │ └── Sprites.hs ├── app ├── Example │ ├── CaveSprites.hs │ ├── Cave2d.hs │ ├── Cave3d.hs │ ├── Noise.hs │ ├── Annealing.hs │ ├── Clustering.hs │ ├── Mountains.hs │ ├── WFC.hs │ └── Isometric.hs └── Main.hs ├── README.md ├── LICENSE ├── berlin.cabal ├── iso-mappings.json └── tile-mappings.json /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /sprites.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/sprites.png -------------------------------------------------------------------------------- /examples/01-noise.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/examples/01-noise.png -------------------------------------------------------------------------------- /examples/04-cave.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/examples/04-cave.png -------------------------------------------------------------------------------- /examples/05-cave.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/examples/05-cave.png -------------------------------------------------------------------------------- /examples/06-cave.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/examples/06-cave.gif -------------------------------------------------------------------------------- /isometric-tiles/dirt.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/dirt.png -------------------------------------------------------------------------------- /isometric-tiles/endE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/endE.png -------------------------------------------------------------------------------- /isometric-tiles/endN.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/endN.png -------------------------------------------------------------------------------- /isometric-tiles/endS.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/endS.png -------------------------------------------------------------------------------- /isometric-tiles/endW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/endW.png -------------------------------------------------------------------------------- /isometric-tiles/lotE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/lotE.png -------------------------------------------------------------------------------- /isometric-tiles/lotN.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/lotN.png -------------------------------------------------------------------------------- /isometric-tiles/lotS.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/lotS.png -------------------------------------------------------------------------------- /isometric-tiles/lotW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/lotW.png -------------------------------------------------------------------------------- /isometric-tiles/road.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/road.png -------------------------------------------------------------------------------- /examples/02-annealing.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/examples/02-annealing.png -------------------------------------------------------------------------------- /examples/03-clustering.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/examples/03-clustering.png -------------------------------------------------------------------------------- /examples/07-mountains.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/examples/07-mountains.png -------------------------------------------------------------------------------- /examples/08-isometric.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/examples/08-isometric.gif -------------------------------------------------------------------------------- /isometric-tiles/beach.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/beach.png -------------------------------------------------------------------------------- /isometric-tiles/beachE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/beachE.png -------------------------------------------------------------------------------- /isometric-tiles/beachN.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/beachN.png -------------------------------------------------------------------------------- /isometric-tiles/beachS.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/beachS.png -------------------------------------------------------------------------------- /isometric-tiles/beachW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/beachW.png -------------------------------------------------------------------------------- /isometric-tiles/exitE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/exitE.png -------------------------------------------------------------------------------- /isometric-tiles/exitN.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/exitN.png -------------------------------------------------------------------------------- /isometric-tiles/exitS.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/exitS.png -------------------------------------------------------------------------------- /isometric-tiles/exitW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/exitW.png -------------------------------------------------------------------------------- /isometric-tiles/grass.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/grass.png -------------------------------------------------------------------------------- /isometric-tiles/hillE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/hillE.png -------------------------------------------------------------------------------- /isometric-tiles/hillES.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/hillES.png -------------------------------------------------------------------------------- /isometric-tiles/hillN.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/hillN.png -------------------------------------------------------------------------------- /isometric-tiles/hillNE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/hillNE.png -------------------------------------------------------------------------------- /isometric-tiles/hillNW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/hillNW.png -------------------------------------------------------------------------------- /isometric-tiles/hillS.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/hillS.png -------------------------------------------------------------------------------- /isometric-tiles/hillSW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/hillSW.png -------------------------------------------------------------------------------- /isometric-tiles/hillW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/hillW.png -------------------------------------------------------------------------------- /isometric-tiles/lotES.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/lotES.png -------------------------------------------------------------------------------- /isometric-tiles/lotNE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/lotNE.png -------------------------------------------------------------------------------- /isometric-tiles/lotNW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/lotNW.png -------------------------------------------------------------------------------- /isometric-tiles/lotSW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/lotSW.png -------------------------------------------------------------------------------- /isometric-tiles/roadES.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadES.png -------------------------------------------------------------------------------- /isometric-tiles/roadEW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadEW.png -------------------------------------------------------------------------------- /isometric-tiles/roadNE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadNE.png -------------------------------------------------------------------------------- /isometric-tiles/roadNS.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadNS.png -------------------------------------------------------------------------------- /isometric-tiles/roadNW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadNW.png -------------------------------------------------------------------------------- /isometric-tiles/roadSW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadSW.png -------------------------------------------------------------------------------- /isometric-tiles/water.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/water.png -------------------------------------------------------------------------------- /isometric-tiles/waterE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/waterE.png -------------------------------------------------------------------------------- /isometric-tiles/waterN.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/waterN.png -------------------------------------------------------------------------------- /isometric-tiles/waterS.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/waterS.png -------------------------------------------------------------------------------- /isometric-tiles/waterW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/waterW.png -------------------------------------------------------------------------------- /isometric-tiles/beachES.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/beachES.png -------------------------------------------------------------------------------- /isometric-tiles/beachNE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/beachNE.png -------------------------------------------------------------------------------- /isometric-tiles/beachNW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/beachNW.png -------------------------------------------------------------------------------- /isometric-tiles/beachSW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/beachSW.png -------------------------------------------------------------------------------- /isometric-tiles/bridgeEW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/bridgeEW.png -------------------------------------------------------------------------------- /isometric-tiles/bridgeNS.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/bridgeNS.png -------------------------------------------------------------------------------- /isometric-tiles/crossroad.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/crossroad.png -------------------------------------------------------------------------------- /isometric-tiles/riverES.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/riverES.png -------------------------------------------------------------------------------- /isometric-tiles/riverEW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/riverEW.png -------------------------------------------------------------------------------- /isometric-tiles/riverNE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/riverNE.png -------------------------------------------------------------------------------- /isometric-tiles/riverNS.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/riverNS.png -------------------------------------------------------------------------------- /isometric-tiles/riverNW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/riverNW.png -------------------------------------------------------------------------------- /isometric-tiles/riverSW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/riverSW.png -------------------------------------------------------------------------------- /isometric-tiles/roadHillE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadHillE.png -------------------------------------------------------------------------------- /isometric-tiles/roadHillN.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadHillN.png -------------------------------------------------------------------------------- /isometric-tiles/roadHillS.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadHillS.png -------------------------------------------------------------------------------- /isometric-tiles/roadHillW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadHillW.png -------------------------------------------------------------------------------- /isometric-tiles/treeShort.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/treeShort.png -------------------------------------------------------------------------------- /isometric-tiles/treeTall.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/treeTall.png -------------------------------------------------------------------------------- /isometric-tiles/waterES.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/waterES.png -------------------------------------------------------------------------------- /isometric-tiles/waterNE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/waterNE.png -------------------------------------------------------------------------------- /isometric-tiles/waterNW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/waterNW.png -------------------------------------------------------------------------------- /isometric-tiles/waterSW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/waterSW.png -------------------------------------------------------------------------------- /isometric-tiles/coniferTall.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/coniferTall.png -------------------------------------------------------------------------------- /isometric-tiles/dirtDouble.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/dirtDouble.png -------------------------------------------------------------------------------- /isometric-tiles/grassWhole.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/grassWhole.png -------------------------------------------------------------------------------- /isometric-tiles/roadHill2E.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadHill2E.png -------------------------------------------------------------------------------- /isometric-tiles/roadHill2N.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadHill2N.png -------------------------------------------------------------------------------- /isometric-tiles/roadHill2S.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadHill2S.png -------------------------------------------------------------------------------- /isometric-tiles/roadHill2W.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/roadHill2W.png -------------------------------------------------------------------------------- /isometric-tiles/treeAltTall.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/treeAltTall.png -------------------------------------------------------------------------------- /isometric-tiles/beachCornerES.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/beachCornerES.png -------------------------------------------------------------------------------- /isometric-tiles/beachCornerNE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/beachCornerNE.png -------------------------------------------------------------------------------- /isometric-tiles/beachCornerNW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/beachCornerNW.png -------------------------------------------------------------------------------- /isometric-tiles/beachCornerSW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/beachCornerSW.png -------------------------------------------------------------------------------- /isometric-tiles/coniferAltTall.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/coniferAltTall.png -------------------------------------------------------------------------------- /isometric-tiles/coniferShort.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/coniferShort.png -------------------------------------------------------------------------------- /isometric-tiles/crossroadESW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/crossroadESW.png -------------------------------------------------------------------------------- /isometric-tiles/crossroadNES.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/crossroadNES.png -------------------------------------------------------------------------------- /isometric-tiles/crossroadNEW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/crossroadNEW.png -------------------------------------------------------------------------------- /isometric-tiles/crossroadNSW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/crossroadNSW.png -------------------------------------------------------------------------------- /isometric-tiles/riverBankedES.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/riverBankedES.png -------------------------------------------------------------------------------- /isometric-tiles/riverBankedEW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/riverBankedEW.png -------------------------------------------------------------------------------- /isometric-tiles/riverBankedNE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/riverBankedNE.png -------------------------------------------------------------------------------- /isometric-tiles/riverBankedNS.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/riverBankedNS.png -------------------------------------------------------------------------------- /isometric-tiles/riverBankedNW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/riverBankedNW.png -------------------------------------------------------------------------------- /isometric-tiles/riverBankedSW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/riverBankedSW.png -------------------------------------------------------------------------------- /isometric-tiles/treeAltShort.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/treeAltShort.png -------------------------------------------------------------------------------- /isometric-tiles/waterCornerES.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/waterCornerES.png -------------------------------------------------------------------------------- /isometric-tiles/waterCornerNE.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/waterCornerNE.png -------------------------------------------------------------------------------- /isometric-tiles/waterCornerNW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/waterCornerNW.png -------------------------------------------------------------------------------- /isometric-tiles/waterCornerSW.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/waterCornerSW.png -------------------------------------------------------------------------------- /isometric-tiles/coniferAltShort.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/i-am-tom/world-building-in-haskell/HEAD/isometric-tiles/coniferAltShort.png -------------------------------------------------------------------------------- /src/Map.hs: -------------------------------------------------------------------------------- 1 | module Map 2 | ( Coordinate, pos, (.+) 3 | , Map, Map_ (..), (?!) 4 | , Nested (..) 5 | , Slice, slice 6 | , Vect (..) 7 | 8 | , create 9 | , dimensions 10 | , kernels 11 | ) where 12 | 13 | import Data.Vect (Vect (..)) 14 | import Map.Coordinate (Coordinate, (.+), pos) 15 | import Map.Kernel (kernels) 16 | import Map.Slice (Slice, slice) 17 | import Map.Type ((?!), Map, Map_ (..), Nested (..), create, dimensions) 18 | import Prelude hiding (iterate) 19 | -------------------------------------------------------------------------------- /src/Generator.hs: -------------------------------------------------------------------------------- 1 | module Generator 2 | ( Smoother (..) 3 | , smooth 4 | , anneal 5 | , cluster 6 | 7 | , boolify 8 | , normal 9 | , perlin 10 | , uniform 11 | 12 | , Cell 13 | , Connections 14 | , Prop 15 | , collapse 16 | , connect 17 | , runAll 18 | , runOne 19 | , runMany 20 | ) where 21 | 22 | import Generator.Noise (boolify, normal, perlin, uniform) 23 | import Generator.Smoother (Smoother (..), smooth, anneal, cluster) 24 | import Generator.WaveFunctionCollapse (Cell, Connections, Prop, collapse, connect, runAll, runOne, runMany) 25 | -------------------------------------------------------------------------------- /src/Data/Nat/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | module Data.Nat.Extra where 6 | 7 | import Data.Nat (Nat (..)) 8 | import GHC.TypeLits (type (-)) 9 | import qualified GHC.TypeLits as TypeLits 10 | 11 | -- | Turn a 'GHC.TypeLits.Nat' into a 'Data.Nat.Nat'. Useful really only to 12 | -- provide a neat API to the users while working internally with a unary 13 | -- representation for convenience (e.g. pattern-matching). 14 | type family Unarise (n :: TypeLits.Nat) :: Nat where 15 | Unarise 0 = 'Z 16 | Unarise n = 'S (Unarise (n - 1)) 17 | 18 | -- | Double a 'Nat' at the type level. We can't call it 'Double', though, 19 | -- because... well, they're already important. 20 | type family Twice (n :: Nat) :: Nat where 21 | Twice 'Z = 'Z 22 | Twice ('S n) = 'S ('S (Twice n)) 23 | -------------------------------------------------------------------------------- /app/Example/CaveSprites.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | module Example.CaveSprites where 6 | 7 | import qualified Codec.Picture as Image 8 | import Control.Lens.Indexed (imap) 9 | import Example.Cave2d (cave) 10 | import qualified Map 11 | import Map (Map, Vect (..)) 12 | import qualified Render 13 | 14 | main :: IO () 15 | main = do 16 | board <- cave (Map.pos @2 40 40) 17 | mapping <- Render.loadMapping "tile-mappings.json" 18 | sprites <- Render.loadSprites "sprites.png" 16 1 19 | 20 | let kernel :: Map 2 (Maybe Bool) -> Int 21 | kernel = sum . imap \(x :. y :. Nil) value -> 22 | case value of 23 | Just False -> 0 24 | _ -> 2 ^ (8 - (y * 3 + x)) 25 | 26 | Image.writePng "examples/05-cave.png" 27 | $ Render.mappedSprites mapping sprites kernel 28 | $ Map.kernels 1 board 29 | -------------------------------------------------------------------------------- /app/Example/Cave2d.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | module Example.Cave2d where 7 | 8 | import qualified Codec.Picture as Image 9 | import qualified Generator 10 | import qualified Map 11 | import Map (Map_ (..), Vect) 12 | import qualified Render 13 | 14 | cave :: Vect n Int -> IO (Map_ n Bool) 15 | cave dimensions = do 16 | board <- case Generator.uniform dimensions of 17 | Just success -> success 18 | Nothing -> error "A dimension isn't greater than 0!" 19 | 20 | let bools = Generator.boolify 0 board 21 | cluster = Generator.cluster 0 22 | 23 | pure (Generator.smooth 2 cluster bools) 24 | 25 | main :: IO () 26 | main = do 27 | board <- cave (Map.pos @2 40 40) 28 | 29 | Image.writePng "examples/04-cave.png" 30 | $ Render.scale 4 31 | $ Render.pixels Render.blackAndWhite 32 | $ board 33 | -------------------------------------------------------------------------------- /app/Example/Cave3d.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | module Example.Cave3d where 6 | 7 | import qualified Codec.Picture as Image 8 | import Data.Functor ((<&>)) 9 | import qualified Data.List.NonEmpty as NonEmpty 10 | import Example.Cave2d (cave) 11 | import qualified Map 12 | import qualified Render 13 | 14 | main :: IO () 15 | main = do 16 | world <- cave (Map.pos @3 40 40 40) 17 | 18 | let toRGB8 :: Image.Pixel8 -> Image.PixelRGB8 19 | toRGB8 x = Image.PixelRGB8 x x x 20 | 21 | frames = Map.slice @2 world <&> \layer -> 22 | Render.scale 8 23 | $ Render.pixels (toRGB8 . Render.blackAndWhite) 24 | $ layer 25 | 26 | animation = Image.writeGifAnimation "examples/06-cave.gif" 27 | 10 Image.LoopingForever (NonEmpty.toList frames) 28 | 29 | case animation of 30 | Left message -> error message 31 | Right gif -> gif 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # World-Building in Haskell 2 | 3 | An introduction to a couple techniques in procedural generation, written in a 4 | language that arguably couldn't be less suited to the task. 5 | 6 | All the visual assets come from the incredible [kenney.nl](https://kenney.nl/) 7 | resources - thoroughly recommend checking them out if, like me, you would love 8 | to play with procedural world generation, but have no artistic ability. 9 | 10 | If you're looking to understand this code, the best place to start is probably 11 | `app/Main.hs`. This should give you an idea of what the different parts of 12 | `src` are doing through some examples. 13 | 14 | ## Examples 15 | 16 | ### Caves from noise and boolean clustering 17 | 18 | Caves 19 | 20 | ### Islands from Perlin noise and heatmap shading 21 | 22 | Perlin 23 | 24 | ### Tiling with WFC 25 | 26 | WaveFunctionCollapse 27 | -------------------------------------------------------------------------------- /src/Render.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | module Render 4 | ( Mapping 5 | , Sprites 6 | , Tiles (..) 7 | 8 | , loadMapping 9 | , loadSprites 10 | 11 | , mappedSprites 12 | , sprites 13 | 14 | , pixels 15 | 16 | , blackAndWhite 17 | , heatmap 18 | , greyscale 19 | 20 | , isometric 21 | 22 | , scale 23 | ) where 24 | 25 | import Codec.Picture (Image (..), Pixel) 26 | import qualified Codec.Picture as Image 27 | import Numeric.Natural (Natural) 28 | import Render.Isometric (Tiles (..), isometric) 29 | import Render.Pixels (blackAndWhite, greyscale, heatmap, pixels) 30 | import Render.Sprites (Mapping, Sprites, loadMapping, loadSprites, mappedSprites, sprites) 31 | 32 | -- | Scale an image by an integer factor. 33 | scale :: Pixel p => Natural -> Image p -> Image p 34 | scale (fromIntegral -> factor) image@Image{..} 35 | = Image.generateImage scaler (factor * imageWidth) (factor * imageHeight) 36 | where scaler i j = Image.pixelAt image (i `div` factor) (j `div` factor) 37 | -------------------------------------------------------------------------------- /app/Example/Noise.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | module Example.Noise where 5 | 6 | import qualified Codec.Picture as Image 7 | import Data.Traversable (for) 8 | import qualified Generator 9 | import qualified Map 10 | import Map ((?!), Coordinate, Map) 11 | import qualified Render 12 | 13 | main :: IO () 14 | main = do 15 | let noises :: [ Coordinate 2 -> Maybe (IO (Map 2 Double)) ] 16 | noises = [ Generator.uniform, Generator.normal, Generator.perlin ] 17 | 18 | tiles <- for noises \noise -> 19 | case noise (Map.pos @2 80 80) of 20 | Just success -> success 21 | Nothing -> error "Uh oh!" 22 | 23 | let pick :: Int -> Int -> Image.Pixel8 24 | pick x y = do 25 | let tile = tiles 26 | !! (x `div` 85) 27 | ?! Map.pos @2 (x `mod` 85) y 28 | 29 | case tile of 30 | Just value -> floor (value * 255) 31 | Nothing -> 255 32 | 33 | Image.writePng "examples/01-noise.png" 34 | $ Render.scale 2 35 | $ Image.generateImage pick 250 80 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Tom Harding 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /app/Example/Annealing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | module Example.Annealing where 4 | 5 | import qualified Codec.Picture as Image 6 | import qualified Generator 7 | import qualified Map 8 | import qualified Render 9 | import Map ((?!)) 10 | 11 | main :: IO () 12 | main = do 13 | initial <- case Generator.uniform (Map.pos @2 80 80) of 14 | Just board -> board 15 | Nothing -> error "Uh oh!" 16 | 17 | let smoother kernel iterations 18 | = Generator.smooth iterations 19 | (Generator.anneal kernel 0) initial 20 | 21 | tiles 22 | = [ smoother k i 23 | | k <- [ 1, 2 ] 24 | , i <- [ 0 .. 4 ] 25 | ] 26 | 27 | let pick :: Int -> Int -> Image.Pixel8 28 | pick x y = do 29 | let tile = tiles 30 | !! ((y `div` 85) * 5 + x `div` 85) 31 | ?! Map.pos @2 (x `mod` 85) (y `mod` 85) 32 | 33 | case tile of 34 | Just value -> floor (value * 255) 35 | Nothing -> 255 36 | 37 | Image.writePng "examples/02-annealing.png" 38 | $ Render.scale 2 39 | $ Image.generateImage pick 420 165 40 | -------------------------------------------------------------------------------- /app/Example/Clustering.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | module Example.Clustering where 4 | 5 | import qualified Codec.Picture as Image 6 | import qualified Generator 7 | import qualified Map 8 | import qualified Render 9 | import Map ((?!)) 10 | 11 | main :: IO () 12 | main = do 13 | initial <- case Generator.uniform (Map.pos @2 80 80) of 14 | Just success -> success 15 | Nothing -> error "Uh oh!" 16 | 17 | let iterator sensitivity iterations 18 | = Generator.smooth iterations (Generator.cluster sensitivity) 19 | $ Generator.boolify 0 initial 20 | 21 | tiles 22 | = [ iterator k i 23 | | k <- [ 0 .. 2 ] 24 | , i <- [ 0 .. 4 ] 25 | ] 26 | 27 | let pick :: Int -> Int -> Image.Pixel8 28 | pick x y = do 29 | let tile = tiles 30 | !! ((y `div` 85) * 5 + x `div` 85) 31 | ?! Map.pos @2 (x `mod` 85) (y `mod` 85) 32 | 33 | case tile of Just True -> 0 34 | _ -> 255 35 | 36 | Image.writePng "examples/03-clustering.png" 37 | $ Render.scale 2 38 | $ Image.generateImage pick 420 250 39 | -------------------------------------------------------------------------------- /app/Example/Mountains.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | module Example.Mountains where 4 | 5 | import qualified Codec.Picture as Image 6 | import qualified Generator 7 | import qualified Map 8 | import qualified Render 9 | 10 | main :: IO () 11 | main = do 12 | board <- case Generator.perlin (Map.pos @2 480 480) of 13 | Just success -> success 14 | Nothing -> error "Uh oh!" 15 | 16 | let snow = (0.85, Image.PixelRGB8 255 255 255) 17 | mountains = ( 0.5, Image.PixelRGB8 200 200 200) 18 | forest = ( 0.1, Image.PixelRGB8 116 151 62) 19 | land = ( 0, Image.PixelRGB8 139 181 74) 20 | sand = (-0.1, Image.PixelRGB8 227 221 188) 21 | shallowWater = ( -2, Image.PixelRGB8 156 213 226) 22 | depths = ( -25, Image.PixelRGB8 74 138 125) 23 | 24 | heatmap :: Double -> Image.PixelRGB8 25 | heatmap = Render.heatmap 26 | [ snow 27 | , mountains 28 | , forest 29 | , land 30 | , sand 31 | , shallowWater 32 | , depths 33 | ] 34 | 35 | Image.writePng "examples/07-mountains.png" 36 | $ Render.pixels heatmap board 37 | -------------------------------------------------------------------------------- /src/Map/Coordinate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | module Map.Coordinate where 9 | 10 | import Data.Nat.Extra (Unarise) 11 | import Data.Vect (Vect (..), Make (..)) 12 | import qualified GHC.TypeLits as TL 13 | import Prelude hiding (subtract) 14 | 15 | -- | For our purposes, an @n@-dimensional coordinate is an @n@-element vector 16 | -- of @Int@ values. Note that it isn't necessarily bounded to a space - 17 | -- coordinates can fall outside our "world". 18 | type Coordinate (n :: TL.Nat) 19 | = Vect (Unarise n) Int 20 | 21 | -- | Add two coordinates (as if they're @n@-dimensional vectors). This allows 22 | -- us to re-frame coordinates in terms of non-origin points. 23 | (.+) :: Vect n Int -> Vect n Int -> Vect n Int 24 | (.+) (x :. xs) (y :. ys) = x + y :. xs .+ ys 25 | (.+) Nil Nil = Nil 26 | 27 | infixr 5 .+ 28 | 29 | -- | Re-export 'Data.Vect.make', but with a 'GHC.TypeLits.Nat' argument to make 30 | -- use of the delicious syntactic sugar. 31 | pos :: forall n k. Make (Unarise n) Int k => k 32 | pos = make @(Unarise n) 33 | -------------------------------------------------------------------------------- /src/Map/Kernel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | module Map.Kernel where 6 | 7 | import Control.Lens.Indexed (FunctorWithIndex (..)) 8 | import Data.Function ((&)) 9 | import Data.List.NonEmpty (NonEmpty (..)) 10 | import Data.Maybe (fromJust) 11 | import Data.Vect (Vect (..)) 12 | import Map.Coordinate ((.+)) 13 | import Map.Type ((?!), Map_ (..)) 14 | import qualified Map.Type as Map 15 | import Numeric.Natural (Natural) 16 | 17 | -- | Construct kernels for every point in the map. Each cell will be replaced 18 | -- by a "submap" containing itself and all the points within @radius@ cells of 19 | -- itself. This can be useful if you want to "smooth" an image, or detect 20 | -- edges, or are trying to implement algorithms like marching squares. 21 | kernels :: Natural -> Map_ n x -> Map_ n (Map_ n (Maybe x)) 22 | kernels (fromIntegral -> radius) board = do 23 | let side :: Int 24 | side = radius * 2 + 1 25 | 26 | dimensions :: Map_ n x -> Vect n Int 27 | dimensions = \case 28 | Axis (r :| _) -> side :. dimensions r 29 | Cell _ -> Nil 30 | 31 | board & imap \global _ -> do 32 | 33 | -- 'fromJust' is safe here as the radius will always be a natural number. 34 | -- This means the smallest it could possibly be is @0 * 2 + 1 = 1@, which 35 | -- is within our bounds. This is tricky to explain to GHC without an awful 36 | -- lot more type machinery, though. 37 | fromJust $ Map.create (dimensions board) \local -> do 38 | let centred = fmap (subtract radius) local 39 | board ?! centred .+ global 40 | -------------------------------------------------------------------------------- /src/Generator/Noise.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MultiWayIf #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | module Generator.Noise where 8 | 9 | import Data.Functor ((<&>)) 10 | import Data.Random.Normal (normalIO') 11 | import Data.Vect (Vect (..)) 12 | import Map (Coordinate, Map, Map_) 13 | import qualified Map as Map 14 | import qualified Numeric.Noise.Perlin as Perlin 15 | import System.Random (randomIO, randomRIO) 16 | 17 | -- | Populate a map with normally-distributed noise using the system's random 18 | -- number generator. The noise will be produced with a mean of @0@ and a 19 | -- standard deviation of @1@. 20 | normal :: Vect n Int -> Maybe (IO (Map_ n Double)) 21 | normal size = fmap sequenceA (Map.create size (const noise)) 22 | where noise = normalIO' (0, 1) 23 | 24 | -- | Populate a map with uniformly-distributed noise using the system's random 25 | -- number generator. The values produced will be from @[-1, 1]@. 26 | uniform :: Vect n Int -> Maybe (IO (Map_ n Double)) 27 | uniform size = fmap sequenceA (Map.create size (const noise)) 28 | where noise = randomRIO (-1, 1) 29 | 30 | -- | Convert a 'Map' of 'Double' values into a 'Map' of 'Bool' values by 31 | -- comparing each cell to a given threshold. If the value of the cell exceeds 32 | -- the threshold, it becomes true. 33 | boolify :: Double -> Map_ n Double -> Map_ n Bool 34 | boolify threshold = fmap (> threshold) 35 | 36 | -- | Two-dimensional Perlin noise (for three-dimensional maps). 37 | perlin :: Coordinate 2 -> Maybe (IO (Map 2 Double)) 38 | perlin dimensions = do 39 | generators <- Map.create dimensions \(x :. y :. Nil) function -> 40 | Perlin.noiseValue function ( fromIntegral x, fromIntegral y, 0 ) 41 | 42 | pure do 43 | function <- randomIO <&> \seed -> 44 | Perlin.perlin seed 4 0.005 0.5 45 | 46 | pure (fmap ($ function) generators) 47 | -------------------------------------------------------------------------------- /src/Render/Pixels.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | module Render.Pixels where 7 | 8 | import Codec.Picture (Image (..), Pixel, Pixel8, PixelRGB8 (..)) 9 | import qualified Codec.Picture as Image 10 | import Data.Bool (bool) 11 | import Data.Foldable (find) 12 | import Data.Maybe (fromJust) 13 | import Data.Vect (Vect (..)) 14 | import qualified Map 15 | import Map ((?!), Map) 16 | 17 | -- | Render a @2@-dimensional image by translating each cell of a @Map@ into a 18 | -- pixel value. The resulting image can be scaled using 'Map.scale' if you're 19 | -- working with small dimensions. 20 | pixels :: forall x p. Pixel p => (x -> p) -> Map 2 x -> Image p 21 | pixels renderer (fmap renderer -> pixelMap) 22 | = Image.generateImage choose width height 23 | where 24 | choose :: Int -> Int -> p 25 | choose x y = fromJust (pixelMap ?! Map.pos @2 x y) 26 | 27 | width :. height :. Nil = Map.dimensions pixelMap 28 | 29 | -- | A monochrome renderer for 'Bool' maps. 'True' maps to black, 'False' to 30 | -- white. 31 | blackAndWhite :: Bool -> Pixel8 32 | blackAndWhite = bool 255 0 33 | 34 | -- | A monochrome renderer for 'Bool' maps. 'True' maps to black, 'False' to 35 | -- white. 36 | greyscale :: Double -> Pixel8 37 | greyscale = max 0 . min 255 . floor . (* 128) . succ 38 | 39 | -- | I didn't have a better name for this, so hopefully the intuition makes 40 | -- sense. Given a list of thresholds and colours, draw a given value in the 41 | -- colour of the first threshold it passes. If these colours are chosen to go 42 | -- from, say, black to red, the effect is like a heat map. However, if these 43 | -- values are altitudes, you can use this to draw terrain maps. 44 | heatmap :: [( Double, PixelRGB8 )] -> Double -> PixelRGB8 45 | heatmap thresholds value 46 | = case find match thresholds of 47 | Just ( _, colour ) -> colour 48 | Nothing -> Image.PixelRGB8 0 0 0 49 | where match ( threshold, _ ) = value > threshold 50 | -------------------------------------------------------------------------------- /src/Map/Slice.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | module Map.Slice 14 | ( Slice 15 | , slice 16 | ) where 17 | 18 | import Data.List.NonEmpty (NonEmpty) 19 | import qualified Data.List.NonEmpty as NonEmpty 20 | import Data.Nat (Nat (..)) 21 | import Data.Nat.Extra (Unarise) 22 | import Map.Type (Map_ (..)) 23 | 24 | -- | Take "slices" of a 'Map_' along a given dimension. For example, we might 25 | -- take a @Map 3 Int@ and 'slice' along dimension @2@ (the @z@ dimension), and 26 | -- this would give us a list of the @2@-dimensional maps taken at each point 27 | -- along the @z@ axis. 28 | slice :: forall i d x. Slice (Unarise i) ('S d) => Map_ ('S d) x -> NonEmpty (Map_ d x) 29 | slice = peel . pull @(Unarise i) 30 | 31 | -- | Get the contents of the 'Axis' constructor of a 'Map_'. 32 | peel :: Map_ ('S m) x -> NonEmpty (Map_ m x) 33 | peel (Axis xs) = xs 34 | 35 | -- | Transpose the two outermost layers of a given 'Map_'. 36 | transpose :: Map_ ('S ('S n)) x -> Map_ ('S ('S n)) x 37 | transpose = Axis . fmap Axis . NonEmpty.transpose . fmap peel . peel 38 | 39 | -- | To implement 'slice', we need to be able to reorder the dimensions within 40 | -- a 'Map_'. This function takes a given dimension, and "pulls" it to the 41 | -- outermost layer. For example, if we "pull" the @z@ dimension of a 3D map, 42 | -- this function will take an @x, y, z@ 'Map_' and return a @z, x, y@ 'Map_'. 43 | -- After that, we can peel back the top layer, and we have our slices! 44 | class Slice (choice :: Nat) (dimensions :: Nat) where 45 | pull :: Map_ dimensions x -> Map_ dimensions x 46 | 47 | instance (Slice n ds, d ~ 'S ds, ds ~ 'S dss) 48 | => Slice ('S n) d where 49 | pull = transpose . Axis . fmap (pull @n) . peel 50 | 51 | instance d ~ 'S n => Slice 'Z d where 52 | pull = id 53 | -------------------------------------------------------------------------------- /app/Example/WFC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | module Example.WFC where 6 | 7 | import Data.List (transpose) 8 | import Data.Set (Set) 9 | import qualified Data.Set as Set 10 | import qualified Generator 11 | import Generator (Connections) 12 | import qualified Map 13 | import Map (Coordinate, Map) 14 | import Text.Show.Unicode (uprint) 15 | 16 | -- | Print a character map to the terminal. 17 | printMap :: Map 2 Char -> IO () 18 | printMap (Map.toNestedLists -> xs) = do 19 | putStrLn mempty 20 | mapM_ uprint (transpose xs) 21 | putStrLn mempty 22 | 23 | -- | Some syntactic sugar for specifying the constraint function. 24 | connect :: (value, value, value, value) -> Connections 4 value 25 | connect (left, right, top, bottom) = Generator.connect @4 left right top bottom 26 | 27 | -- | The constraint function: specify the valid neighbours for each possible 28 | -- tile. 29 | maze :: Maybe Char -> Connections 4 (Set Char) 30 | maze = fmap Set.fromList . connect . \case 31 | Just '─' -> ( left , right , noTop , noBottom ) 32 | Just '│' -> ( noLeft , noRight , top , bottom ) 33 | Just '┼' -> ( left , right , top , bottom ) 34 | Just '┌' -> ( noLeft , right , noTop , bottom ) 35 | Just '┘' -> ( left , noRight , noTop , bottom ) 36 | Just '└' -> ( noLeft , right , top , noBottom ) 37 | Just '┐' -> ( left , noRight , noTop , bottom ) 38 | Just '┴' -> ( left , right , noTop , bottom ) 39 | Just '┬' -> ( left , right , top , noBottom ) 40 | Just '├' -> ( noLeft , right , top , bottom ) 41 | Just '┤' -> ( left , noRight , top , bottom ) 42 | Just _ -> ( noLeft , noRight , noTop , noBottom ) 43 | Nothing -> ( left , right , top , bottom ) 44 | where 45 | left = "─┼┌└┴┬├" 46 | noLeft = " │┘┐┤" 47 | right = "─┼┐┘┴┬┤" 48 | noRight = " │└┌├" 49 | top = "│┼┌┐┬├┤" 50 | noTop = " ─┘└┴" 51 | bottom = "│┼└┘┴├┤" 52 | noBottom = " ─┐┌┬" 53 | 54 | main :: IO () 55 | main = do 56 | let dimensions :: Coordinate 2 57 | dimensions = Map.pos @2 40 20 58 | 59 | initial :: [ Char ] 60 | initial = " ─│┼┌┘└┐┴┬├┤" 61 | 62 | Generator.runOne (Generator.collapse dimensions initial maze) >>= \case 63 | Just result -> printMap result 64 | Nothing -> error "Couldn't produce a map!" 65 | -------------------------------------------------------------------------------- /berlin.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | 3 | name: berlin 4 | version: 0.1.0.0 5 | license-file: LICENSE 6 | author: Tom Harding 7 | maintainer: tomjharding@live.co.uk 8 | build-type: Simple 9 | 10 | executable berlin 11 | main-is: Main.hs 12 | build-depends: base 13 | , aeson 14 | , berlin 15 | , containers 16 | , JuicyPixels 17 | , lens 18 | , unicode-show 19 | , unordered-containers 20 | default-language: Haskell2010 21 | hs-source-dirs: app 22 | ghc-options: -Wall -Wextra 23 | other-modules: Example.Annealing 24 | , Example.Cave2d 25 | , Example.Cave3d 26 | , Example.CaveSprites 27 | , Example.Clustering 28 | , Example.Mountains 29 | , Example.Noise 30 | , Example.WFC 31 | , Example.Isometric 32 | 33 | library 34 | exposed-modules: Generator 35 | , Map 36 | , Render 37 | 38 | other-modules: Data.Nat.Extra 39 | , Data.Vect 40 | , Generator.Noise 41 | , Generator.Smoother 42 | , Generator.WaveFunctionCollapse 43 | , Map.Coordinate 44 | , Map.Kernel 45 | , Map.Slice 46 | , Map.Type 47 | , Render.Isometric 48 | , Render.Pixels 49 | , Render.Sprites 50 | 51 | build-depends: base 52 | , JuicyPixels 53 | , QuickCheck 54 | , aeson 55 | , containers 56 | , containers 57 | , generic-lens 58 | , filepath 59 | , fin 60 | , hsnoise 61 | , logict 62 | , lens 63 | , mtl 64 | , normaldistribution 65 | , primitive 66 | , random 67 | , transformers 68 | , unicode-show 69 | , vector 70 | , ghc-typelits-natnormalise 71 | hs-source-dirs: src 72 | default-language: Haskell2010 73 | ghc-options: -Wall -Wextra 74 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Example.Noise 4 | import qualified Example.Annealing 5 | import qualified Example.Clustering 6 | import qualified Example.Cave2d 7 | import qualified Example.CaveSprites 8 | import qualified Example.Cave3d 9 | import qualified Example.Mountains 10 | import qualified Example.WFC 11 | import qualified Example.Isometric 12 | 13 | main :: IO () 14 | main = do 15 | 16 | -- Comparison of uniform, normal, and Perlin noise. There's not a huge 17 | -- difference between normal and uniform at this scale, but Perlin is quite 18 | -- strikingly different. 19 | putStrLn "Noise comparison..." 20 | Example.Noise.main 21 | 22 | -- Examples of "annealing" - smoothing noise by repeatedly averaging a kernel 23 | -- around a cell. The top line shows a 3x3 kernel being used to average the 24 | -- noise 5 times, while the bottom line shows a 5x5 kernel. 25 | putStrLn "Annealing stages..." 26 | Example.Annealing.main 27 | 28 | -- Examples of "clustering" - given some boolean noise, repeatedly assign a 29 | -- cell to the most common value in its kernel. The three rows show 30 | -- increasing "tolerance" - if the difference in numbers between the two 31 | -- boolean counts is within @2 * tolerance@, the cell is unchanged, meaning 32 | -- the output maintains its noise. 33 | putStrLn "Clustering stages..." 34 | Example.Clustering.main 35 | 36 | -- Putting together what we now know, we can draw a simple cave and render it 37 | -- in black and white. 38 | putStrLn "2D caves..." 39 | Example.Cave2d.main 40 | 41 | -- We can even use kernels to map the cells to sprites, to make things look a 42 | -- bit friendlier. 43 | putStrLn "2D caves with sprites..." 44 | Example.CaveSprites.main 45 | 46 | -- What's maybe not obvious before now, however, is that 47 | -- our process is polymorphic over any number of dimensions, so we can use 48 | -- the same result to produce __three-dimensional__ caves! 49 | putStrLn "3D caves..." 50 | Example.Cave3d.main 51 | 52 | -- Caves look best when they're this stochastic, but terrains often need to 53 | -- look a bit more gradual in their variations. For that reason, we can use 54 | -- Perlin noise to create something more appropriate. It takes a fair amount 55 | -- of (manual) tuning of the various parameters to the Perlin function to get 56 | -- the result you want, but it's great once you're there! 57 | putStrLn "Mountains..." 58 | Example.Mountains.main 59 | 60 | -- Another approach to procedural generation (that can be used alongside the 61 | -- previous techniques!) is WaveFunctionCollapse. The idea is that you 62 | -- specify, for each possible tile, what its neighbours could be. Then, using 63 | -- random selection and backtracking, the algorithm finds a configuration of 64 | -- tiles that satisfies all the connections between neighbours. 65 | putStrLn "WFC..." 66 | Example.WFC.main 67 | 68 | putStrLn "Iso..." 69 | Example.Isometric.main 70 | -------------------------------------------------------------------------------- /src/Generator/Smoother.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | module Generator.Smoother 7 | ( Smoother (..) 8 | , smooth 9 | 10 | , anneal 11 | , cluster 12 | ) where 13 | 14 | import Data.Foldable (toList) 15 | import Data.Kind (Type) 16 | import Data.List (delete) 17 | import Data.Maybe (fromMaybe) 18 | import Data.Nat (Nat) 19 | import qualified Map 20 | import Map (Map_) 21 | import Numeric.Natural (Natural) 22 | 23 | -- | A 'Smoother' defines an iterative operation over some 'Map'. Typically, 24 | -- these are used /after/ some noise generation: the smoothing algorithm tries 25 | -- to use the noise to produce an "organic" effect. 26 | data Smoother (n :: Nat) (x :: Type) 27 | = Smoother 28 | { _step :: Map_ n (Maybe x) -> x -- ^ The smoothing algorithm 29 | , _size :: Natural -- ^ How big a kernel do we need? 30 | } 31 | 32 | -- | Repeatedly apply (for a given number of iterations) a smoothing function 33 | -- to a map. Typically, the higher the number of iterations, the less "noisy" 34 | -- the result. 35 | smooth :: Int -> Smoother n x -> Map_ n x -> Map_ n x 36 | smooth iterations _ 37 | | iterations < 1 = id 38 | smooth iterations smoother@Smoother{..} 39 | = smooth (iterations - 1) smoother 40 | . fmap _step 41 | . Map.kernels _size 42 | 43 | -- | Assign each cell to the average of the values in its kernel. The more this 44 | -- smoother is iterated, the closer every value will come to converging on a 45 | -- common number. The parameters dictate the size of the kernel and the value 46 | -- to be used for "out-of-bounds" cells. 47 | anneal :: Fractional x => Natural -> x -> Smoother n x 48 | anneal _size border 49 | = Smoother 50 | { _step = \kernel -> do 51 | let corrected = fmap (fromMaybe border) kernel 52 | sum corrected / fromIntegral (length corrected) 53 | 54 | , .. 55 | } 56 | 57 | -- | Given a map of 'Bool' values, this smoother assigns each cell to the most 58 | -- common value among its neighbours. If the difference between the number of 59 | -- 'True' and 'False' neighbours is less than @2 * tolerance@, the value is 60 | -- unchanged. 61 | cluster :: Int -> Smoother n Bool 62 | cluster tolerance = Smoother 63 | { _step = \(toList -> kernel) -> do 64 | let middle :: Int 65 | middle = length kernel `div` 2 66 | 67 | original :: Maybe Bool 68 | original = kernel !! middle 69 | 70 | trues :: Int -- How many true neighbours do I have? 71 | trues = length (filter (fromMaybe True) (delete original kernel)) 72 | 73 | if | trues < middle - tolerance -> False 74 | | trues > middle + tolerance -> True 75 | 76 | -- Of course, the bool should always be present in the centre of the 77 | -- kernel, as it's always sampled from /inside/ the map. 78 | | otherwise -> fromMaybe True original 79 | 80 | , _size = 1 81 | } 82 | -------------------------------------------------------------------------------- /src/Render/Isometric.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | module Render.Isometric where 8 | 9 | import Codec.Picture (Image, PixelRGBA8 (..)) 10 | import qualified Codec.Picture as Image 11 | import qualified Codec.Picture.Types as Image (createMutableImage, freezeImage) 12 | import Control.Lens ((^@..), itraversed) 13 | import Data.Foldable (for_) 14 | import Data.Vect (Vect (..)) 15 | import GHC.Exts (sortWith) 16 | import qualified Map 17 | import Map (Coordinate, Map) 18 | import System.FilePath (()) 19 | 20 | -- | Configuration for an isometric tileset. Unlike a sprite sheet, because of 21 | -- the irregular shape, we'll store the tiles as separate images, and load them 22 | -- from a given directory. 23 | data Tiles 24 | = Tiles 25 | { _x, _y, _z :: Int 26 | , _directory :: FilePath 27 | } 28 | deriving (Eq, Ord, Show) 29 | 30 | -- | Calculate the dimensions of an isometric render's canvas. We assume that 31 | -- tiles overlap by the height of the tile depth, and so the height is 32 | -- calculated by assuming tiles are @full height - depth@ tall, and adding an 33 | -- extra @depth@ value to the bottom. 34 | canvasSize :: Coordinate 3 -> Tiles -> Coordinate 2 35 | canvasSize ( x :. y :. z :. Nil ) Tiles{..} = width :. height :. Nil 36 | where 37 | width :: Int 38 | width = ( x + y ) * _x `div` 2 39 | 40 | height :: Int 41 | height = ( x + y ) * ( _y - _z ) `div` 2 + ( z * _z ) 42 | 43 | -- | Calculate the top-left point (ignoring depth) of a tile at the given 44 | -- coordinate when projected onto the output image. From this point, we can 45 | -- draw the rest. 46 | position :: Coordinate 3 -> Coordinate 3 -> Tiles -> Coordinate 2 47 | position ( _ :. h :. _ :. Nil ) ( x :. y :. z :. Nil ) Tiles{..} 48 | = left :. top :. Nil 49 | where 50 | left :: Int 51 | left = ( h - 1 + x - y ) * _x `div` 2 52 | 53 | top :: Int 54 | top = ( x + y ) * ( _y - _z ) `div` 2 + ( z * _z ) 55 | 56 | -- | Arrange the tiles in render order. We should render the tiles at the 57 | -- "back" before the tiles at the "front" to avoid overlap. 58 | queue :: Map 3 x -> [( Coordinate 3, x )] 59 | queue xs = sortWith (zIndex . fst) (xs ^@.. itraversed) 60 | where 61 | zIndex :: Coordinate 3 -> Int 62 | zIndex ( x :. y :. _ :. Nil ) = x + y 63 | 64 | -- | Render a @3@-dimensional map to an isometric canvas. The @renderer@ 65 | -- function should map each cell to the tile file. 66 | isometric :: Tiles -> (x -> FilePath) -> Map 3 x -> IO (Image PixelRGBA8) 67 | isometric tiles@Tiles{..} renderer (fmap renderer -> board) = do 68 | let width :. height :. Nil = canvasSize dimensions tiles 69 | dimensions = Map.dimensions board 70 | 71 | canvas <- Image.createMutableImage width height (PixelRGBA8 0 0 0 0) 72 | 73 | for_ (queue board) \(coordinate, path) -> do 74 | let ox :. oy :. Nil = position dimensions coordinate tiles 75 | offsets = do 76 | x <- [ 0 .. _x - 1 ] 77 | y <- [ 0 .. _y - 1 ] 78 | 79 | pure (x, y) 80 | 81 | sprite <- Image.readPng (_directory path <> ".png") >>= \case 82 | Right success -> pure (Image.convertRGBA8 success) 83 | Left message -> error message 84 | 85 | for_ offsets \( x, y ) -> 86 | let x' = ox + x 87 | y' = oy + y 88 | 89 | in case Image.pixelAt sprite x y of 90 | PixelRGBA8 _ _ _ 0 -> pure () 91 | solid -> Image.writePixel canvas x' y' solid 92 | 93 | Image.freezeImage canvas 94 | -------------------------------------------------------------------------------- /src/Data/Vect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | module Data.Vect where 15 | 16 | import Data.Foldable (sequenceA_) 17 | import Data.Kind (Type) 18 | import Data.Monoid (Ap (..)) 19 | import Data.Nat (Nat (..)) 20 | import Prelude hiding (zip, zipWith) 21 | 22 | -- | Length-indexed list type. A @Vect 2 Int@ contains __exactly__ two @Int@ 23 | -- values. 24 | data Vect (n :: Nat) (x :: Type) where 25 | Nil :: Vect 'Z x 26 | (:.) :: x -> Vect n x -> Vect ('S n) x 27 | 28 | infixr 4 :. 29 | 30 | deriving instance Eq x => Eq (Vect n x) 31 | deriving instance Functor (Vect n) 32 | deriving instance Foldable (Vect n) 33 | deriving instance Traversable (Vect n) 34 | 35 | deriving via (Ap (Vect n) x) 36 | instance (Applicative (Vect n), Num x) 37 | => Num (Vect n x) 38 | 39 | deriving via (Ap (Vect n) x) 40 | instance (Applicative (Vect n), Semigroup x) 41 | => Semigroup (Vect n x) 42 | 43 | deriving via (Ap (Vect n) x) 44 | instance (Applicative (Vect n), Monoid x) 45 | => Monoid (Vect n x) 46 | 47 | instance Show x => Show (Vect n x) where 48 | show = show . toList 49 | 50 | instance Applicative (Vect 'Z) where 51 | pure _ = Nil 52 | _ <*> _ = Nil 53 | 54 | instance Applicative (Vect n) 55 | => Applicative (Vect ('S n)) where 56 | pure x = x :. pure x 57 | (f :. fs) <*> (x :. xs) = f x :. (fs <*> xs) 58 | 59 | -- | Construct a vector without the constructor noise. Given a number of 60 | -- arguments, this constructs a function to populate a vector. 61 | -- 62 | -- >>> make @'Z 63 | -- Vect 'Z x 64 | -- 65 | -- >>> make @('S 'Z) 66 | -- x -> Vect ('S 'Z) x 67 | -- 68 | -- >>> make @('S ('S 'Z)) 69 | -- x -> x -> Vect ('S ('S 'Z)) x 70 | class Make (count :: Nat) (value :: Type) (signature :: Type) 71 | | count value -> signature 72 | , signature -> count value where 73 | make :: signature 74 | 75 | instance Make_ n n x k => Make n x k where 76 | make = make_ @n id 77 | 78 | class Make_ (todo :: Nat) (total :: Nat) (value :: Type) (output :: Type) 79 | | todo total value -> output 80 | , output -> value total where 81 | make_ :: (Vect todo value -> Vect total value) -> output 82 | 83 | instance k ~ Vect n x => Make_ 'Z n x k where 84 | make_ f = f Nil 85 | 86 | instance (Make_ i n x ks, k ~ (x -> ks)) => Make_ ('S i) n x k where 87 | make_ f x = make_ @i \xs -> f (x :. xs) 88 | 89 | -- | Convert a 'Vect' to a list, "forgetting" the number of elements. 90 | toList :: Vect n x -> [ x ] 91 | toList = \case 92 | x :. xs -> x : toList xs 93 | Nil -> [] 94 | 95 | -- | Zip two vectors together. These vectors must be the same length. 96 | zip :: Vect n x -> Vect n y -> Vect n (x, y) 97 | zip (x :. xs) (y :. ys) = (x, y) :. zip xs ys 98 | zip Nil Nil = Nil 99 | 100 | -- | Zip two equal-length vectors together with a given function. 101 | zipWith :: (x -> y -> z) -> Vect n x -> Vect n y -> Vect n z 102 | zipWith f (x :. xs) (y :. ys) = f x y :. zipWith f xs ys 103 | zipWith _ Nil Nil = Nil 104 | 105 | -- | Zip two equal-length vectors together using a given effectful function. 106 | zipWithA :: Applicative f => (x -> y -> f z) -> Vect n x -> Vect n y -> f (Vect n z) 107 | zipWithA f xs ys = sequenceA (zipWith f xs ys) 108 | 109 | -- | Zip two equal-length vectors together using a given effectful function, 110 | -- and discard the result. 111 | zipWithA_ :: Applicative f => (x -> y -> f z) -> Vect n x -> Vect n y -> f () 112 | zipWithA_ f xs ys = sequenceA_ (zipWith f xs ys) 113 | -------------------------------------------------------------------------------- /src/Map/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# LANGUAGE ViewPatterns #-} 12 | module Map.Type where 13 | 14 | import qualified Control.Lens.Indexed as Ix 15 | import Data.Function ((&)) 16 | import Data.Kind (Type) 17 | import Data.List.NonEmpty ((!!), NonEmpty (..), nonEmpty) 18 | import qualified Data.List.NonEmpty as NonEmpty 19 | import Data.Nat (Nat (..)) 20 | import Data.Nat.Extra (Unarise) 21 | import Data.Traversable (for) 22 | import Data.Vect (Vect (..)) 23 | import qualified GHC.TypeLits as TL 24 | import Prelude hiding ((!!), iterate) 25 | 26 | -- | A map is an @n@-dimensional matrix indexed by the number of dimensions and 27 | -- the type contained in every "cell". 28 | -- 29 | -- Note that we don't index by the dimensions themselves: because operations 30 | -- such as kernels don't necessarily have to stay "within the boundaries", 31 | -- we're OK with being able to point to coordinates "off-grid". 32 | data Map_ (n :: Nat) (x :: Type) where 33 | Axis :: NonEmpty (Map_ n x) -> Map_ ('S n) x 34 | Cell :: x -> Map_ 'Z x 35 | 36 | type Map (n :: TL.Nat) 37 | = Map_ (Unarise n) 38 | 39 | deriving instance Eq x => Eq (Map_ n x) 40 | -- deriving instance Show x => Show (Map_ n x) 41 | deriving instance Foldable (Map_ n) 42 | deriving instance Functor (Map_ n) 43 | deriving instance Traversable (Map_ n) 44 | 45 | instance (Nested n x o, Show o) 46 | => Show (Map_ n x) where 47 | show xs = "MAP " <> show (toNestedLists xs) 48 | 49 | instance Ix.FoldableWithIndex (Vect n Int) (Map_ n) where 50 | ifoldMap f = \case 51 | Axis xs -> xs & Ix.ifoldMap \i -> Ix.ifoldMap \is -> f (i :. is) 52 | Cell x -> f Nil x 53 | 54 | instance Ix.FunctorWithIndex (Vect n Int) (Map_ n) where 55 | imap f = \case 56 | Axis xs -> Axis $ xs & Ix.imap \i -> Ix.imap \is -> f (i :. is) 57 | Cell x -> Cell (f Nil x) 58 | 59 | instance Ix.TraversableWithIndex (Vect n Int) (Map_ n) where 60 | itraverse f = \case 61 | Axis xs -> fmap Axis $ xs & Ix.itraverse \i -> Ix.itraverse \is -> f (i :. is) 62 | Cell x -> fmap Cell (f Nil x) 63 | 64 | -- | Look up the value at a given coordinate on the 'Map_'. Note that the 65 | -- coordinate can reference a position outside the boundaries of the 'Map_', so 66 | -- the operation may find 'Nothing'. 67 | (?!) :: Map_ n x -> Vect n Int -> Maybe x 68 | (?!) (Axis xs) ((fromIntegral -> i) :. is) 69 | | i >= 0 && i < length xs = (xs !! i) ?! is 70 | (?!) (Cell x) Nil = Just x 71 | (?!) _ _ = Nothing 72 | 73 | infixr 3 ?! 74 | 75 | -- | Create a new 'Map_' with the given dimensions. Each cell is filled by 76 | -- passing the cell's coordinate to the given function. All dimensions must be 77 | -- non-zero; if you need a zero dimension, it can just be ommitted (as we'll 78 | -- never be able to place anything on the map). 79 | create :: Vect n Int -> (Vect n Int -> x) -> Maybe (Map_ n x) 80 | create Nil f = Just (Cell (f Nil)) 81 | create (i :. _ ) _ 82 | | i <= 0 = Nothing 83 | create (i :. is) f = do 84 | indices <- nonEmpty [ 0 .. i - 1 ] 85 | subdimensions <- for indices \n -> 86 | create is \ns -> f (n :. ns) 87 | 88 | pure (Axis subdimensions) 89 | 90 | -- | Get the dimensions of a 'Map_'. This assumes that all side lengths are 91 | -- equal (which is true of all 'Map_' values obtained via 'create'). 92 | dimensions :: Map_ n x -> Vect n Int 93 | dimensions = \case 94 | Axis (r :| rs) -> length rs + 1 :. dimensions r 95 | Cell _ -> Nil 96 | 97 | -- | Convert a 'Map_' into a nested array. This /is/ a forgetful operation, as 98 | -- we can't tell how many dimensions were in the map that produced 99 | -- @[[[Bool]]]@: was it @3@ dimensions of @Bool@, or @2@ of @[Bool]@? 100 | class Nested (dimensions :: Nat) (cells :: Type) (result :: Type) 101 | | dimensions cells -> result 102 | , dimensions result -> cells where 103 | toNestedLists :: Map_ dimensions cells -> result 104 | 105 | instance x ~ o => Nested 'Z x o where 106 | toNestedLists (Cell x) = x 107 | 108 | instance (Nested n x os, o ~ [os]) => Nested ('S n) x o where 109 | toNestedLists (Axis rs) = map toNestedLists (NonEmpty.toList rs) 110 | -------------------------------------------------------------------------------- /app/Example/Isometric.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE DerivingStrategies #-} 7 | {-# LANGUAGE GeneralisedNewtypeDeriving #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | module Example.Isometric where 13 | 14 | import Codec.Picture (PixelRGB8 (..), PixelRGBA8 (..)) 15 | import qualified Codec.Picture as Image 16 | import Data.Aeson (FromJSON, ToJSON) 17 | import qualified Data.Aeson as Aeson 18 | import Data.HashMap.Strict (HashMap) 19 | import qualified Data.HashMap.Strict as HashMap 20 | import Data.Set (Set) 21 | import qualified Data.Set as Set 22 | import Data.Traversable (for) 23 | import GHC.Generics (Generic) 24 | import qualified Generator 25 | import Generator (Connections) 26 | import qualified Map 27 | import Map (Coordinate) 28 | import qualified Render 29 | import Render (Tiles (..)) 30 | import Text.Printf (printf) 31 | 32 | -- | The six types of terrains that meet at the edges of the tiles. 33 | data Terrain 34 | = Sand | Water | Grass | Road | Dirt | Banked | Sky 35 | deriving stock (Eq, Generic, Ord, Show) 36 | deriving anyclass (FromJSON, ToJSON) 37 | 38 | -- | Each edge can have three terrains (e.g. beach on one side, water on the 39 | -- other). 40 | newtype Edge 41 | = Edge (Terrain, Terrain, Terrain) 42 | deriving stock (Eq, Ord, Show) 43 | deriving newtype (Generic) 44 | deriving anyclass (FromJSON, ToJSON) 45 | 46 | -- | Each tile borders 6 others (west, east, north, south, up, down). 47 | newtype Borders 48 | = Borders (Edge, Edge, Edge, Edge, Edge, Edge) 49 | deriving stock (Eq, Ord, Show) 50 | deriving newtype (Generic) 51 | deriving anyclass (FromJSON, ToJSON) 52 | 53 | -- | Configuration for mapping is a hashmap from the tile's image name to the 54 | -- ( North, East, South, West ) edges. 55 | newtype Config 56 | = Config { toHashMap :: HashMap FilePath Borders } 57 | deriving stock (Eq, Ord, Show) 58 | deriving newtype (FromJSON, ToJSON) 59 | 60 | -- | There are six sides to a 3D tile. 61 | data Side = North | East | South | West | Up | Down 62 | 63 | -- | Look up the connecting tiles in the config. 64 | connections :: Borders -> Config -> Connections 6 (Set FilePath) 65 | connections (Borders (w, e, n, s, u, d)) (Config config) 66 | = fmap (Set.fromList . get . filterer) 67 | $ Generator.connect @6 West East North South Up Down 68 | where 69 | get :: (Borders -> Bool) -> [ FilePath ] 70 | get f = HashMap.keys (HashMap.filter f config) 71 | 72 | filterer :: Side -> Borders -> Bool 73 | filterer side (Borders (w', e', n', s', u', d')) 74 | = case side of 75 | North -> n == s' 76 | East -> e == w' 77 | South -> s == n' 78 | West -> w == e' 79 | Up -> u == d' 80 | Down -> d == u' 81 | 82 | -- | Given a config, create a constraint function. 83 | makeConstraints :: Config -> Maybe FilePath -> Connections 6 (Set FilePath) 84 | makeConstraints config@(Config hashMap) = \case 85 | Just filepath | Just borders <- HashMap.lookup filepath hashMap -> 86 | connections borders config 87 | 88 | _ -> Generator.connect @6 idc idc idc idc idc idc 89 | where idc = Set.fromList (HashMap.keys hashMap) 90 | 91 | main :: IO () 92 | main = do 93 | config@(Config hashMap) <- 94 | Aeson.eitherDecodeFileStrict "iso-mappings.json" >>= \case 95 | Right success -> pure success 96 | Left message -> error message 97 | 98 | let dimensions :: Coordinate 3 99 | dimensions = Map.pos @3 10 10 1 100 | 101 | constraints :: Maybe FilePath -> Connections 6 (Set FilePath) 102 | constraints = makeConstraints config 103 | 104 | initial :: [ FilePath ] 105 | initial = HashMap.keys hashMap 106 | 107 | frames <- for [ 1 .. 50 ] \i -> do 108 | putStrLn (printf "%d / 50" (i :: Int)) 109 | 110 | Generator.runOne (Generator.collapse dimensions initial constraints) >>= \case 111 | Nothing -> error "Couldn't produce a map!" 112 | Just result -> Render.isometric (Tiles 100 65 15 "isometric-tiles") id result 113 | 114 | let opaque = \case 115 | PixelRGBA8 _ _ _ 0 -> PixelRGB8 255 255 255 116 | PixelRGBA8 r g b _ -> PixelRGB8 r g b 117 | 118 | animation = Image.writeGifAnimation "examples/08-isometric.gif" 119 | 30 Image.LoopingForever (map (Image.pixelMap opaque) frames) 120 | 121 | putStrLn "Rendering..." 122 | case animation of 123 | Left message -> error message 124 | Right gif -> gif 125 | -------------------------------------------------------------------------------- /src/Render/Sprites.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | module Render.Sprites 11 | ( mappedSprites 12 | , sprites 13 | 14 | , Mapping 15 | , getMapping 16 | , getAllMappings 17 | , loadMapping 18 | 19 | , Sprites 20 | , loadSprites 21 | , getSprite 22 | , getAllSprites 23 | ) where 24 | 25 | import Codec.Picture (DynamicImage, Image, Pixel, PixelRGBA8 (..)) 26 | import qualified Codec.Picture as Image 27 | import Control.Monad ((>=>)) 28 | import Data.Aeson (FromJSON, ToJSON) 29 | import qualified Data.Aeson as JSON 30 | import Data.Functor ((<&>)) 31 | import Data.Maybe (fromMaybe) 32 | import Data.Vector ((!?), Vector) 33 | import Data.Vect (Vect (..)) 34 | import GHC.Generics (Generic) 35 | import qualified Map 36 | import Map ((?!), Map, Map_) 37 | import Prelude hiding (lookup) 38 | 39 | -- | Render some sprites using an external mapping. The third argument will 40 | -- take the value in a cell and map it to an index within the mapping, which 41 | -- will correspond to the sprite to use. This is helpful when you're working 42 | -- with a large set of sprites. 43 | mappedSprites :: Mapping -> Sprites -> (x -> Int) -> Map 2 x -> Image PixelRGBA8 44 | mappedSprites mapping spritesheet f 45 | = sprites spritesheet (getMapping mapping . f) 46 | 47 | -- | Render a map to an image using an external sprite sheet. Every cell is 48 | -- mapped to a coordinate within the sprite sheet, and that sprite is rendered 49 | -- to that @x@/@y@ position in the final image. 50 | sprites :: Sprites -> (x -> ( Int, Int )) -> Map 2 x -> Image PixelRGBA8 51 | sprites reference@Sprites{..} position board = do 52 | let cellToTileImage = Image.convertRGBA8 . getSprite reference . position 53 | width :. height :. Nil = Map.dimensions board 54 | 55 | pixel x y = do 56 | let (spriteX, i) = x `divMod` _size 57 | (spriteY, j) = y `divMod` _size 58 | 59 | fromMaybe (Image.PixelRGBA8 0 0 0 0) do 60 | board ?! Map.pos @2 spriteX spriteY <&> \cell -> 61 | Image.pixelAt (cellToTileImage cell) i j 62 | 63 | Image.generateImage pixel (width * _size) (height * _size) 64 | 65 | -- | When we're choosing tiles based on kernels, the mapping from kernels to 66 | -- tiles can become very large. So we don't clutter our Haskell code, we can 67 | -- store the 'Mapping' in an external file. This file should contain a JSON 68 | -- object, with two keys: 69 | -- 70 | -- - @positions@, which holds a vector of sprite positions. Users can look up 71 | -- these positions based on their indices. 72 | -- - @fallback@, which is returned if the user-supplied index is out-of-bounds. 73 | data Mapping 74 | = Mapping 75 | { fallback :: ( Int, Int ) 76 | , positions :: Vector ( Int, Int ) 77 | } 78 | deriving stock (Eq, Generic, Ord, Show) 79 | deriving anyclass (ToJSON, FromJSON) 80 | 81 | -- | Load a mapping from disk. 82 | loadMapping :: FilePath -> IO Mapping 83 | loadMapping = JSON.eitherDecodeFileStrict' >=> either error pure 84 | 85 | -- | Look up a sprite position by its mapping index. 86 | getMapping :: Mapping -> Int -> ( Int, Int ) 87 | getMapping Mapping{..} = fromMaybe fallback . (positions !?) 88 | 89 | -- | Given a board of indices, replace each cell with the position it 90 | -- references according to the mapping. 91 | getAllMappings :: Mapping -> Map_ n Int -> Map_ n ( Int, Int ) 92 | getAllMappings = fmap . getMapping 93 | 94 | -- | A sprite sheet is a large file containing lots of tiles that we can put 95 | -- together to render our scene. The tiles are assumed to be square, and spaced 96 | -- with a regular margin. 97 | data Sprites 98 | = Sprites 99 | { _margin :: Int 100 | , _sheet :: DynamicImage 101 | , _size :: Int 102 | } 103 | deriving Eq 104 | 105 | -- | Load a sprite sheet with a given tile size and margin. It's assumed that 106 | -- a sprite position @(x, y)@ can be scaled by @size + margin@ to find the 107 | -- pixel-value coordinate of its top-left corner. The bottom right is therefore 108 | -- @(x * (size + margin) + size, y * (size + margin) + size)@. 109 | loadSprites :: FilePath -> Int -> Int -> IO Sprites 110 | loadSprites filepath _size _margin 111 | = Image.readPng filepath >>= \case 112 | Right _sheet -> pure Sprites{..} 113 | Left message -> error message 114 | 115 | -- | Get the sprite at a given index from a sprite sheet. 116 | getSprite :: Sprites -> ( Int, Int ) -> DynamicImage 117 | getSprite Sprites{..} ( x, y ) = do 118 | let mapping :: Pixel px => Image px -> Image px 119 | mapping image = do 120 | let getPixel i j = do 121 | let x' = x * scale + i 122 | y' = y * scale + j 123 | 124 | Image.pixelAt image x' y' 125 | 126 | Image.generateImage getPixel _size _size 127 | 128 | scale = _size + _margin 129 | 130 | Image.dynamicPixelMap mapping _sheet 131 | 132 | -- | Convert a map of positions to a map of sprites. 133 | getAllSprites :: Sprites -> Map_ n ( Int, Int ) -> Map_ n DynamicImage 134 | getAllSprites = fmap . getSprite 135 | -------------------------------------------------------------------------------- /iso-mappings.json: -------------------------------------------------------------------------------- 1 | { "grass": [ 2 | [ "Grass", "Grass", "Grass" ], 3 | [ "Grass", "Grass", "Grass" ], 4 | [ "Grass", "Grass", "Grass" ], 5 | [ "Grass", "Grass", "Grass" ], 6 | [ "Sky", "Sky", "Sky" ], 7 | [ "Dirt", "Dirt", "Dirt" ] 8 | ], 9 | 10 | "riverBankedES": [ 11 | [ "Grass", "Grass", "Grass" ], 12 | [ "Grass", "Water", "Grass" ], 13 | [ "Grass", "Water", "Grass" ], 14 | [ "Grass", "Grass", "Grass" ], 15 | [ "Sky", "Sky", "Sky" ], 16 | [ "Dirt", "Dirt", "Dirt" ] 17 | ], 18 | 19 | "riverBankedEW": [ 20 | [ "Grass", "Grass", "Grass" ], 21 | [ "Grass", "Grass", "Grass" ], 22 | [ "Grass", "Water", "Grass" ], 23 | [ "Grass", "Water", "Grass" ], 24 | [ "Sky", "Sky", "Sky" ], 25 | [ "Dirt", "Dirt", "Dirt" ] 26 | ], 27 | 28 | "riverBankedNE": [ 29 | [ "Grass", "Water", "Grass" ], 30 | [ "Grass", "Grass", "Grass" ], 31 | [ "Grass", "Water", "Grass" ], 32 | [ "Grass", "Grass", "Grass" ], 33 | [ "Sky", "Sky", "Sky" ], 34 | [ "Dirt", "Dirt", "Dirt" ] 35 | ], 36 | 37 | "riverBankedNS": [ 38 | [ "Grass", "Water", "Grass" ], 39 | [ "Grass", "Water", "Grass" ], 40 | [ "Grass", "Grass", "Grass" ], 41 | [ "Grass", "Grass", "Grass" ], 42 | [ "Sky", "Sky", "Sky" ], 43 | [ "Dirt", "Dirt", "Dirt" ] 44 | ], 45 | 46 | "riverBankedNW": [ 47 | [ "Grass", "Water", "Grass" ], 48 | [ "Grass", "Grass", "Grass" ], 49 | [ "Grass", "Grass", "Grass" ], 50 | [ "Grass", "Water", "Grass" ], 51 | [ "Sky", "Sky", "Sky" ], 52 | [ "Dirt", "Dirt", "Dirt" ] 53 | ], 54 | 55 | "riverBankedSW": [ 56 | [ "Grass", "Grass", "Grass" ], 57 | [ "Grass", "Water", "Grass" ], 58 | [ "Grass", "Grass", "Grass" ], 59 | [ "Grass", "Water", "Grass" ], 60 | [ "Sky", "Sky", "Sky" ], 61 | [ "Dirt", "Dirt", "Dirt" ] 62 | ], 63 | 64 | "roadES": [ 65 | [ "Grass", "Grass", "Grass" ], 66 | [ "Grass", "Road", "Grass" ], 67 | [ "Grass", "Road", "Grass" ], 68 | [ "Grass", "Grass", "Grass" ], 69 | [ "Sky", "Sky", "Sky" ], 70 | [ "Dirt", "Dirt", "Dirt" ] 71 | ], 72 | 73 | "roadEW": [ 74 | [ "Grass", "Grass", "Grass" ], 75 | [ "Grass", "Grass", "Grass" ], 76 | [ "Grass", "Road", "Grass" ], 77 | [ "Grass", "Road", "Grass" ], 78 | [ "Sky", "Sky", "Sky" ], 79 | [ "Dirt", "Dirt", "Dirt" ] 80 | ], 81 | 82 | "roadNE": [ 83 | [ "Grass", "Road", "Grass" ], 84 | [ "Grass", "Grass", "Grass" ], 85 | [ "Grass", "Road", "Grass" ], 86 | [ "Grass", "Grass", "Grass" ], 87 | [ "Sky", "Sky", "Sky" ], 88 | [ "Dirt", "Dirt", "Dirt" ] 89 | ], 90 | 91 | "roadNS": [ 92 | [ "Grass", "Road", "Grass" ], 93 | [ "Grass", "Road", "Grass" ], 94 | [ "Grass", "Grass", "Grass" ], 95 | [ "Grass", "Grass", "Grass" ], 96 | [ "Sky", "Sky", "Sky" ], 97 | [ "Dirt", "Dirt", "Dirt" ] 98 | ], 99 | 100 | "roadNW": [ 101 | [ "Grass", "Road", "Grass" ], 102 | [ "Grass", "Grass", "Grass" ], 103 | [ "Grass", "Grass", "Grass" ], 104 | [ "Grass", "Road", "Grass" ], 105 | [ "Sky", "Sky", "Sky" ], 106 | [ "Dirt", "Dirt", "Dirt" ] 107 | ], 108 | 109 | "roadSW": [ 110 | [ "Grass", "Grass", "Grass" ], 111 | [ "Grass", "Road", "Grass" ], 112 | [ "Grass", "Grass", "Grass" ], 113 | [ "Grass", "Road", "Grass" ], 114 | [ "Sky", "Sky", "Sky" ], 115 | [ "Dirt", "Dirt", "Dirt" ] 116 | ], 117 | 118 | "water": [ 119 | [ "Water", "Water", "Water" ], 120 | [ "Water", "Water", "Water" ], 121 | [ "Water", "Water", "Water" ], 122 | [ "Water", "Water", "Water" ], 123 | [ "Sky", "Sky", "Sky" ], 124 | [ "Dirt", "Dirt", "Dirt" ] 125 | ], 126 | 127 | "waterCornerES": [ 128 | [ "Water", "Water", "Water" ], 129 | [ "Water", "Water", "Grass" ], 130 | [ "Water", "Water", "Grass" ], 131 | [ "Water", "Water", "Water" ], 132 | [ "Sky", "Sky", "Sky" ], 133 | [ "Dirt", "Dirt", "Dirt" ] 134 | ], 135 | 136 | "waterCornerNE": [ 137 | [ "Water", "Water", "Grass" ], 138 | [ "Water", "Water", "Water" ], 139 | [ "Grass", "Water", "Water" ], 140 | [ "Water", "Water", "Water" ], 141 | [ "Sky", "Sky", "Sky" ], 142 | [ "Dirt", "Dirt", "Dirt" ] 143 | ], 144 | 145 | "waterCornerNW": [ 146 | [ "Grass", "Water", "Water" ], 147 | [ "Water", "Water", "Water" ], 148 | [ "Water", "Water", "Water" ], 149 | [ "Grass", "Water", "Water" ], 150 | [ "Sky", "Sky", "Sky" ], 151 | [ "Dirt", "Dirt", "Dirt" ] 152 | ], 153 | 154 | "waterCornerSW": [ 155 | [ "Water", "Water", "Water" ], 156 | [ "Grass", "Water", "Water" ], 157 | [ "Water", "Water", "Water" ], 158 | [ "Water", "Water", "Grass" ], 159 | [ "Sky", "Sky", "Sky" ], 160 | [ "Dirt", "Dirt", "Dirt" ] 161 | ], 162 | 163 | "waterE": [ 164 | [ "Water", "Water", "Grass" ], 165 | [ "Water", "Water", "Grass" ], 166 | [ "Grass", "Grass", "Grass" ], 167 | [ "Water", "Water", "Water" ], 168 | [ "Sky", "Sky", "Sky" ], 169 | [ "Dirt", "Dirt", "Dirt" ] 170 | ], 171 | 172 | "waterES": [ 173 | [ "Water", "Water", "Grass" ], 174 | [ "Grass", "Grass", "Grass" ], 175 | [ "Grass", "Grass", "Grass" ], 176 | [ "Water", "Water", "Grass" ], 177 | [ "Sky", "Sky", "Sky" ], 178 | [ "Dirt", "Dirt", "Dirt" ] 179 | ], 180 | 181 | "waterN": [ 182 | [ "Grass", "Grass", "Grass" ], 183 | [ "Water", "Water", "Water" ], 184 | [ "Grass", "Water", "Water" ], 185 | [ "Grass", "Water", "Water" ], 186 | [ "Sky", "Sky", "Sky" ], 187 | [ "Dirt", "Dirt", "Dirt" ] 188 | ], 189 | 190 | "waterNE": [ 191 | [ "Grass", "Grass", "Grass" ], 192 | [ "Water", "Water", "Grass" ], 193 | [ "Grass", "Grass", "Grass" ], 194 | [ "Grass", "Water", "Water" ], 195 | [ "Sky", "Sky", "Sky" ], 196 | [ "Dirt", "Dirt", "Dirt" ] 197 | ], 198 | 199 | "waterNW": [ 200 | [ "Grass", "Grass", "Grass" ], 201 | [ "Grass", "Water", "Water" ], 202 | [ "Grass", "Water", "Water" ], 203 | [ "Grass", "Grass", "Grass" ], 204 | [ "Sky", "Sky", "Sky" ], 205 | [ "Dirt", "Dirt", "Dirt" ] 206 | ], 207 | 208 | "waterS": [ 209 | [ "Water", "Water", "Water" ], 210 | [ "Grass", "Grass", "Grass" ], 211 | [ "Water", "Water", "Grass" ], 212 | [ "Water", "Water", "Grass" ], 213 | [ "Sky", "Sky", "Sky" ], 214 | [ "Dirt", "Dirt", "Dirt" ] 215 | ], 216 | 217 | "waterSW": [ 218 | [ "Grass", "Water", "Water" ], 219 | [ "Grass", "Grass", "Grass" ], 220 | [ "Water", "Water", "Grass" ], 221 | [ "Grass", "Grass", "Grass" ], 222 | [ "Sky", "Sky", "Sky" ], 223 | [ "Dirt", "Dirt", "Dirt" ] 224 | ], 225 | 226 | "waterW": [ 227 | [ "Grass", "Water", "Water" ], 228 | [ "Grass", "Water", "Water" ], 229 | [ "Water", "Water", "Water" ], 230 | [ "Grass", "Grass", "Grass" ], 231 | [ "Sky", "Sky", "Sky" ], 232 | [ "Dirt", "Dirt", "Dirt" ] 233 | ] 234 | } 235 | -------------------------------------------------------------------------------- /tile-mappings.json: -------------------------------------------------------------------------------- 1 | { "fallback": [ 0, 0 ] 2 | , "positions": 3 | [ [ 20, 12 ] 4 | , [ 20, 12 ] 5 | , [ 20, 12 ] 6 | , [ 20, 12 ] 7 | , [ 20, 12 ] 8 | , [ 20, 12 ] 9 | , [ 20, 12 ] 10 | , [ 20, 12 ] 11 | , [ 20, 12 ] 12 | , [ 20, 12 ] 13 | , [ 20, 12 ] 14 | , [ 20, 12 ] 15 | , [ 20, 12 ] 16 | , [ 20, 12 ] 17 | , [ 20, 12 ] 18 | , [ 20, 12 ] 19 | , [ 9, 1 ] 20 | , [ 9, 1 ] 21 | , [ 8, 0 ] 22 | , [ 8, 0 ] 23 | , [ 9, 1 ] 24 | , [ 9, 1 ] 25 | , [ 8, 0 ] 26 | , [ 8, 0 ] 27 | , [ 9, 0 ] 28 | , [ 9, 0 ] 29 | , [ 12, 0 ] 30 | , [ 12, 0 ] 31 | , [ 9, 0 ] 32 | , [ 9, 0 ] 33 | , [ 12, 0 ] 34 | , [ 12, 0 ] 35 | , [ 20, 12 ] 36 | , [ 20, 12 ] 37 | , [ 20, 12 ] 38 | , [ 20, 12 ] 39 | , [ 20, 12 ] 40 | , [ 20, 12 ] 41 | , [ 20, 12 ] 42 | , [ 20, 12 ] 43 | , [ 20, 12 ] 44 | , [ 20, 12 ] 45 | , [ 20, 12 ] 46 | , [ 20, 12 ] 47 | , [ 20, 12 ] 48 | , [ 20, 12 ] 49 | , [ 20, 12 ] 50 | , [ 20, 12 ] 51 | , [ 11, 0 ] 52 | , [ 11, 0 ] 53 | , [ 13, 0 ] 54 | , [ 13, 0 ] 55 | , [ 11, 0 ] 56 | , [ 11, 0 ] 57 | , [ 13, 0 ] 58 | , [ 13, 0 ] 59 | , [ 10, 0 ] 60 | , [ 10, 0 ] 61 | , [ 15, 1 ] 62 | , [ 15, 1 ] 63 | , [ 10, 0 ] 64 | , [ 10, 0 ] 65 | , [ 15, 1 ] 66 | , [ 15, 1 ] 67 | , [ 20, 12 ] 68 | , [ 20, 12 ] 69 | , [ 20, 12 ] 70 | , [ 20, 12 ] 71 | , [ 20, 12 ] 72 | , [ 20, 12 ] 73 | , [ 20, 12 ] 74 | , [ 20, 12 ] 75 | , [ 20, 12 ] 76 | , [ 20, 12 ] 77 | , [ 20, 12 ] 78 | , [ 20, 12 ] 79 | , [ 20, 12 ] 80 | , [ 20, 12 ] 81 | , [ 20, 12 ] 82 | , [ 20, 12 ] 83 | , [ 9, 1 ] 84 | , [ 9, 1 ] 85 | , [ 8, 0 ] 86 | , [ 8, 0 ] 87 | , [ 9, 1 ] 88 | , [ 9, 1 ] 89 | , [ 8, 0 ] 90 | , [ 8, 0 ] 91 | , [ 9, 0 ] 92 | , [ 9, 0 ] 93 | , [ 12, 0 ] 94 | , [ 12, 0 ] 95 | , [ 9, 0 ] 96 | , [ 9, 0 ] 97 | , [ 12, 0 ] 98 | , [ 12, 0 ] 99 | , [ 20, 12 ] 100 | , [ 20, 12 ] 101 | , [ 20, 12 ] 102 | , [ 20, 12 ] 103 | , [ 20, 12 ] 104 | , [ 20, 12 ] 105 | , [ 20, 12 ] 106 | , [ 20, 12 ] 107 | , [ 20, 12 ] 108 | , [ 20, 12 ] 109 | , [ 20, 12 ] 110 | , [ 20, 12 ] 111 | , [ 20, 12 ] 112 | , [ 20, 12 ] 113 | , [ 20, 12 ] 114 | , [ 20, 12 ] 115 | , [ 11, 0 ] 116 | , [ 11, 0 ] 117 | , [ 13, 0 ] 118 | , [ 13, 0 ] 119 | , [ 11, 0 ] 120 | , [ 11, 0 ] 121 | , [ 13, 0 ] 122 | , [ 13, 0 ] 123 | , [ 10, 0 ] 124 | , [ 10, 0 ] 125 | , [ 15, 1 ] 126 | , [ 15, 1 ] 127 | , [ 10, 0 ] 128 | , [ 10, 0 ] 129 | , [ 15, 1 ] 130 | , [ 15, 1 ] 131 | , [ 11, 4 ] 132 | , [ 11, 4 ] 133 | , [ 11, 4 ] 134 | , [ 11, 4 ] 135 | , [ 11, 4 ] 136 | , [ 11, 4 ] 137 | , [ 11, 4 ] 138 | , [ 11, 4 ] 139 | , [ 9, 4 ] 140 | , [ 9, 4 ] 141 | , [ 9, 4 ] 142 | , [ 9, 4 ] 143 | , [ 9, 4 ] 144 | , [ 9, 4 ] 145 | , [ 9, 4 ] 146 | , [ 9, 4 ] 147 | , [ 8, 1 ] 148 | , [ 8, 1 ] 149 | , [ 11, 1 ] 150 | , [ 11, 1 ] 151 | , [ 9, 1 ] 152 | , [ 9, 1 ] 153 | , [ 11, 1 ] 154 | , [ 11, 1 ] 155 | , [ 12, 1 ] 156 | , [ 12, 1 ] 157 | , [ 14, 0 ] 158 | , [ 14, 0 ] 159 | , [ 12, 1 ] 160 | , [ 12, 1 ] 161 | , [ 14, 0 ] 162 | , [ 14, 0 ] 163 | , [ 10, 4 ] 164 | , [ 10, 4 ] 165 | , [ 10, 4 ] 166 | , [ 10, 4 ] 167 | , [ 10, 4 ] 168 | , [ 10, 4 ] 169 | , [ 10, 4 ] 170 | , [ 10, 4 ] 171 | , [ 9, 4 ] 172 | , [ 9, 4 ] 173 | , [ 9, 4 ] 174 | , [ 9, 4 ] 175 | , [ 9, 4 ] 176 | , [ 9, 4 ] 177 | , [ 9, 4 ] 178 | , [ 9, 4 ] 179 | , [ 13, 1 ] 180 | , [ 13, 1 ] 181 | , [ 14, 1 ] 182 | , [ 14, 1 ] 183 | , [ 13, 1 ] 184 | , [ 13, 1 ] 185 | , [ 14, 1 ] 186 | , [ 14, 1 ] 187 | , [ 15, 0 ] 188 | , [ 15, 0 ] 189 | , [ 10, 1 ] 190 | , [ 10, 1 ] 191 | , [ 15, 0 ] 192 | , [ 15, 0 ] 193 | , [ 10, 1 ] 194 | , [ 10, 1 ] 195 | , [ 8, 4 ] 196 | , [ 8, 4 ] 197 | , [ 8, 4 ] 198 | , [ 8, 4 ] 199 | , [ 8, 4 ] 200 | , [ 8, 4 ] 201 | , [ 8, 4 ] 202 | , [ 8, 4 ] 203 | , [ 8, 4 ] 204 | , [ 8, 4 ] 205 | , [ 8, 4 ] 206 | , [ 8, 4 ] 207 | , [ 8, 4 ] 208 | , [ 8, 4 ] 209 | , [ 8, 4 ] 210 | , [ 8, 4 ] 211 | , [ 9, 1 ] 212 | , [ 9, 1 ] 213 | , [ 11, 1 ] 214 | , [ 11, 1 ] 215 | , [ 8, 1 ] 216 | , [ 8, 1 ] 217 | , [ 11, 1 ] 218 | , [ 11, 1 ] 219 | , [ 12, 1 ] 220 | , [ 12, 1 ] 221 | , [ 14, 0 ] 222 | , [ 14, 0 ] 223 | , [ 12, 1 ] 224 | , [ 12, 1 ] 225 | , [ 14, 0 ] 226 | , [ 14, 0 ] 227 | , [ 9, 4 ] 228 | , [ 9, 4 ] 229 | , [ 9, 4 ] 230 | , [ 9, 4 ] 231 | , [ 9, 4 ] 232 | , [ 9, 4 ] 233 | , [ 9, 4 ] 234 | , [ 9, 4 ] 235 | , [ 9, 4 ] 236 | , [ 9, 4 ] 237 | , [ 9, 4 ] 238 | , [ 9, 4 ] 239 | , [ 9, 4 ] 240 | , [ 9, 4 ] 241 | , [ 9, 4 ] 242 | , [ 9, 4 ] 243 | , [ 13, 1 ] 244 | , [ 13, 1 ] 245 | , [ 14, 1 ] 246 | , [ 14, 1 ] 247 | , [ 13, 1 ] 248 | , [ 13, 1 ] 249 | , [ 14, 1 ] 250 | , [ 14, 1 ] 251 | , [ 15, 0 ] 252 | , [ 15, 0 ] 253 | , [ 10, 1 ] 254 | , [ 10, 1 ] 255 | , [ 15, 0 ] 256 | , [ 15, 0 ] 257 | , [ 10, 1 ] 258 | , [ 10, 1 ] 259 | , [ 20, 12 ] 260 | , [ 20, 12 ] 261 | , [ 20, 12 ] 262 | , [ 20, 12 ] 263 | , [ 20, 12 ] 264 | , [ 20, 12 ] 265 | , [ 20, 12 ] 266 | , [ 20, 12 ] 267 | , [ 20, 12 ] 268 | , [ 20, 12 ] 269 | , [ 20, 12 ] 270 | , [ 20, 12 ] 271 | , [ 20, 12 ] 272 | , [ 20, 12 ] 273 | , [ 20, 12 ] 274 | , [ 20, 12 ] 275 | , [ 9, 1 ] 276 | , [ 9, 1 ] 277 | , [ 8, 0 ] 278 | , [ 8, 0 ] 279 | , [ 9, 1 ] 280 | , [ 9, 1 ] 281 | , [ 8, 0 ] 282 | , [ 8, 0 ] 283 | , [ 9, 0 ] 284 | , [ 9, 0 ] 285 | , [ 12, 0 ] 286 | , [ 12, 0 ] 287 | , [ 9, 0 ] 288 | , [ 9, 0 ] 289 | , [ 12, 0 ] 290 | , [ 12, 0 ] 291 | , [ 20, 12 ] 292 | , [ 20, 12 ] 293 | , [ 20, 12 ] 294 | , [ 20, 12 ] 295 | , [ 20, 12 ] 296 | , [ 20, 12 ] 297 | , [ 20, 12 ] 298 | , [ 20, 12 ] 299 | , [ 20, 12 ] 300 | , [ 20, 12 ] 301 | , [ 20, 12 ] 302 | , [ 20, 12 ] 303 | , [ 20, 12 ] 304 | , [ 20, 12 ] 305 | , [ 20, 12 ] 306 | , [ 20, 12 ] 307 | , [ 11, 0 ] 308 | , [ 11, 0 ] 309 | , [ 13, 0 ] 310 | , [ 13, 0 ] 311 | , [ 11, 0 ] 312 | , [ 11, 0 ] 313 | , [ 13, 0 ] 314 | , [ 13, 0 ] 315 | , [ 10, 0 ] 316 | , [ 10, 0 ] 317 | , [ 15, 1 ] 318 | , [ 15, 1 ] 319 | , [ 10, 0 ] 320 | , [ 10, 0 ] 321 | , [ 15, 1 ] 322 | , [ 15, 1 ] 323 | , [ 20, 12 ] 324 | , [ 20, 12 ] 325 | , [ 20, 12 ] 326 | , [ 20, 12 ] 327 | , [ 20, 12 ] 328 | , [ 20, 12 ] 329 | , [ 20, 12 ] 330 | , [ 20, 12 ] 331 | , [ 20, 12 ] 332 | , [ 20, 12 ] 333 | , [ 20, 12 ] 334 | , [ 20, 12 ] 335 | , [ 20, 12 ] 336 | , [ 20, 12 ] 337 | , [ 20, 12 ] 338 | , [ 20, 12 ] 339 | , [ 9, 1 ] 340 | , [ 9, 1 ] 341 | , [ 8, 0 ] 342 | , [ 8, 0 ] 343 | , [ 9, 1 ] 344 | , [ 9, 1 ] 345 | , [ 8, 0 ] 346 | , [ 8, 0 ] 347 | , [ 9, 0 ] 348 | , [ 9, 0 ] 349 | , [ 12, 0 ] 350 | , [ 12, 0 ] 351 | , [ 9, 0 ] 352 | , [ 9, 0 ] 353 | , [ 12, 0 ] 354 | , [ 12, 0 ] 355 | , [ 20, 12 ] 356 | , [ 20, 12 ] 357 | , [ 20, 12 ] 358 | , [ 20, 12 ] 359 | , [ 20, 12 ] 360 | , [ 20, 12 ] 361 | , [ 20, 12 ] 362 | , [ 20, 12 ] 363 | , [ 20, 12 ] 364 | , [ 20, 12 ] 365 | , [ 20, 12 ] 366 | , [ 20, 12 ] 367 | , [ 20, 12 ] 368 | , [ 20, 12 ] 369 | , [ 20, 12 ] 370 | , [ 20, 12 ] 371 | , [ 11, 0 ] 372 | , [ 11, 0 ] 373 | , [ 13, 0 ] 374 | , [ 13, 0 ] 375 | , [ 11, 0 ] 376 | , [ 11, 0 ] 377 | , [ 13, 0 ] 378 | , [ 13, 0 ] 379 | , [ 10, 0 ] 380 | , [ 10, 0 ] 381 | , [ 15, 1 ] 382 | , [ 15, 1 ] 383 | , [ 10, 0 ] 384 | , [ 10, 0 ] 385 | , [ 15, 1 ] 386 | , [ 15, 1 ] 387 | , [ 10, 4 ] 388 | , [ 10, 4 ] 389 | , [ 10, 4 ] 390 | , [ 10, 4 ] 391 | , [ 10, 4 ] 392 | , [ 10, 4 ] 393 | , [ 10, 4 ] 394 | , [ 10, 4 ] 395 | , [ 10, 4 ] 396 | , [ 10, 4 ] 397 | , [ 10, 4 ] 398 | , [ 10, 4 ] 399 | , [ 10, 4 ] 400 | , [ 10, 4 ] 401 | , [ 10, 4 ] 402 | , [ 10, 4 ] 403 | , [ 8, 1 ] 404 | , [ 8, 1 ] 405 | , [ 11, 1 ] 406 | , [ 11, 1 ] 407 | , [ 8, 1 ] 408 | , [ 8, 1 ] 409 | , [ 11, 1 ] 410 | , [ 11, 1 ] 411 | , [ 12, 1 ] 412 | , [ 12, 1 ] 413 | , [ 14, 0 ] 414 | , [ 14, 0 ] 415 | , [ 12, 1 ] 416 | , [ 12, 1 ] 417 | , [ 14, 0 ] 418 | , [ 14, 0 ] 419 | , [ 10, 4 ] 420 | , [ 10, 4 ] 421 | , [ 10, 4 ] 422 | , [ 10, 4 ] 423 | , [ 10, 4 ] 424 | , [ 10, 4 ] 425 | , [ 10, 4 ] 426 | , [ 10, 4 ] 427 | , [ 9, 4 ] 428 | , [ 9, 4 ] 429 | , [ 9, 4 ] 430 | , [ 9, 4 ] 431 | , [ 9, 4 ] 432 | , [ 9, 4 ] 433 | , [ 9, 4 ] 434 | , [ 9, 4 ] 435 | , [ 13, 1 ] 436 | , [ 13, 1 ] 437 | , [ 14, 1 ] 438 | , [ 14, 1 ] 439 | , [ 13, 1 ] 440 | , [ 13, 1 ] 441 | , [ 14, 1 ] 442 | , [ 14, 1 ] 443 | , [ 15, 0 ] 444 | , [ 15, 0 ] 445 | , [ 10, 1 ] 446 | , [ 10, 1 ] 447 | , [ 15, 0 ] 448 | , [ 15, 0 ] 449 | , [ 10, 1 ] 450 | , [ 10, 1 ] 451 | , [ 9, 4 ] 452 | , [ 9, 4 ] 453 | , [ 9, 4 ] 454 | , [ 9, 4 ] 455 | , [ 9, 4 ] 456 | , [ 9, 4 ] 457 | , [ 9, 4 ] 458 | , [ 9, 4 ] 459 | , [ 9, 4 ] 460 | , [ 9, 4 ] 461 | , [ 9, 4 ] 462 | , [ 9, 4 ] 463 | , [ 9, 4 ] 464 | , [ 9, 4 ] 465 | , [ 9, 4 ] 466 | , [ 9, 4 ] 467 | , [ 8, 1 ] 468 | , [ 8, 1 ] 469 | , [ 11, 1 ] 470 | , [ 11, 1 ] 471 | , [ 8, 1 ] 472 | , [ 8, 1 ] 473 | , [ 11, 1 ] 474 | , [ 11, 1 ] 475 | , [ 12, 1 ] 476 | , [ 12, 1 ] 477 | , [ 14, 0 ] 478 | , [ 14, 0 ] 479 | , [ 12, 1 ] 480 | , [ 12, 1 ] 481 | , [ 14, 0 ] 482 | , [ 14, 0 ] 483 | , [ 9, 4 ] 484 | , [ 9, 4 ] 485 | , [ 9, 4 ] 486 | , [ 9, 4 ] 487 | , [ 9, 4 ] 488 | , [ 9, 4 ] 489 | , [ 9, 4 ] 490 | , [ 9, 4 ] 491 | , [ 9, 4 ] 492 | , [ 9, 4 ] 493 | , [ 9, 4 ] 494 | , [ 9, 4 ] 495 | , [ 9, 4 ] 496 | , [ 9, 4 ] 497 | , [ 9, 4 ] 498 | , [ 9, 4 ] 499 | , [ 13, 1 ] 500 | , [ 13, 1 ] 501 | , [ 14, 1 ] 502 | , [ 14, 1 ] 503 | , [ 13, 1 ] 504 | , [ 13, 1 ] 505 | , [ 14, 1 ] 506 | , [ 14, 1 ] 507 | , [ 15, 0 ] 508 | , [ 15, 0 ] 509 | , [ 10, 1 ] 510 | , [ 10, 1 ] 511 | , [ 15, 0 ] 512 | , [ 15, 0 ] 513 | , [ 10, 1 ] 514 | , [ 10, 1 ] 515 | ] 516 | } 517 | -------------------------------------------------------------------------------- /src/Generator/WaveFunctionCollapse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE GeneralisedNewtypeDeriving #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-# LANGUAGE ViewPatterns #-} 14 | module Generator.WaveFunctionCollapse 15 | ( Cell 16 | , Connections 17 | , Prop 18 | 19 | , collapse 20 | , connect 21 | , runAll 22 | , runMany 23 | , runOne 24 | ) where 25 | 26 | import Control.Applicative ((<|>), Alternative, empty) 27 | import Control.Lens ((<>~), (^@..), (.~), (^..), _1, _2, _head, _last, itraversed, to) 28 | import Control.Lens.Indexed (ifor_) 29 | import Control.Monad (guard, unless) 30 | import Control.Monad.IO.Class (MonadIO (..)) 31 | import Control.Monad.Logic (LogicT) 32 | import qualified Control.Monad.Logic as Logic 33 | import Control.Monad.Primitive (PrimMonad (..)) 34 | import Data.Foldable (asum, for_, traverse_) 35 | import Data.Function (on) 36 | import Data.Kind (Type) 37 | import Data.List.NonEmpty ((!!)) 38 | import qualified Data.List.NonEmpty as NonEmpty 39 | import Data.Maybe (fromMaybe, listToMaybe) 40 | import Data.Monoid (Ap (..)) 41 | import Data.Nat.Extra (Twice) 42 | import Data.Nat.Extra (Unarise) 43 | import Data.Primitive.MutVar (MutVar) 44 | import qualified Data.Primitive.MutVar as Prim 45 | import Data.Set (Set) 46 | import qualified Data.Set as Set 47 | import Data.Unique (Unique, newUnique) 48 | import Data.Vect (Make (..), Vect (..), zipWithA_) 49 | import GHC.Exts (groupWith, sortWith) 50 | import qualified GHC.TypeLits as TL 51 | import qualified Map 52 | import Map ((?!), Map_) 53 | import Prelude hiding ((!!), read, until) 54 | import qualified Test.QuickCheck.Gen as Gen 55 | 56 | -- | There are several ways to express the WaveFunctionCollapse, but I find 57 | -- propagators to be the most natural fit - in essence, WFC is really just one 58 | -- specialised form of a propagator network, albeit one that uses randomness 59 | -- and ends up a little less "pure". 60 | -- 61 | -- It's probably more helpful to skip straight down to 'collapse', and come 62 | -- back to the internals later, once you have an intuition for what's going on. 63 | newtype Prop (x :: Type) 64 | = Prop { runProp :: LogicT IO x } 65 | deriving newtype (Functor, Alternative, Applicative, Monad, MonadIO) 66 | deriving (Semigroup, Monoid) via (Ap (LogicT IO) x) 67 | 68 | instance PrimMonad Prop where 69 | type PrimState Prop = PrimState IO 70 | primitive = Prop . Logic.lift . primitive 71 | 72 | -- | Run a propagator computation, returning an array of results. Note that, in 73 | -- most WFC applications, there are a /lot/ of possible permutations (we're 74 | -- talking millions), so this operation may be extremely slow. It's probably 75 | -- more sensible to use @runOne@ or @runMany@ and just take a few at a time. 76 | runAll :: Prop x -> IO [ x ] 77 | runAll = Logic.observeAllT . runProp 78 | 79 | -- | Run a propagator computation, returning the first successful permutation 80 | -- (if it exists). This has the advantage of terminating immediately, and so 81 | -- will perform much faster than @runAll@. 82 | runOne :: Prop x -> IO (Maybe x) 83 | runOne = fmap listToMaybe . Logic.observeManyT 1 . runProp 84 | 85 | -- | Run a propagator computation, returning a given number of results (or 86 | -- fewer if there aren't that many successes). 87 | runMany :: Int -> Prop x -> IO (Maybe x) 88 | runMany count = fmap listToMaybe . Logic.observeManyT count . runProp 89 | 90 | -------------------------------------------------- 91 | 92 | -- | Cells are the basic value storage in a propagator network. In our 93 | -- specialised version, a cell holds a set of "possible values", and we 94 | -- eliminate values from this set over time. We consider a value "collapsed" 95 | -- when only one possible candidate remains. 96 | data Cell (x :: Type) 97 | = Cell 98 | { _id :: Unique 99 | , _ref :: MutVar (PrimState Prop) (Set x, Prop ()) 100 | } 101 | 102 | instance Eq (Cell x) where (==) = (==) `on` _id 103 | instance Ord (Cell x) where compare = compare `on` _id 104 | 105 | -- | Create a new 'Cell' containing the given list of possible values. 106 | fill :: Ord x => [ x ] -> Prop (Cell x) 107 | fill (Set.fromList -> xs) = do 108 | _id <- liftIO newUnique 109 | _ref <- Prim.newMutVar (xs, mempty) 110 | 111 | pure Cell{..} 112 | 113 | -- | Read the current possible candidates for a given 'Cell'. 114 | read :: Cell x -> Prop (Set x) 115 | read = fmap fst . Prim.readMutVar . _ref 116 | 117 | -- | Register a callback on a 'Cell'. Every time that 'Cell' is updated, its 118 | -- remaining candidates will be passed to the function, which should in turn 119 | -- try to write updates to other cells, and thus trigger even more callbacks. 120 | -- 121 | -- Note that we can backtrack this operation - if something goes wrong, we 122 | -- return the cell to its original state. 123 | watch :: Cell x -> (Set x -> Prop ()) -> Prop () 124 | watch cell@Cell{..} callback = do 125 | let propagator = read cell >>= callback 126 | ( _, propagators ) <- Prim.readMutVar _ref 127 | 128 | Prim.modifyMutVar _ref (_2 <>~ propagator) *> propagator 129 | <|> Prim.modifyMutVar _ref (_2 .~ propagators) *> empty 130 | 131 | -- | Write an update to a 'Cell'. Here, we write a set of possibilities, which 132 | -- we call @news@. We then read the 'Cell' to find the @olds@. The 133 | -- /intersection/ of the two is stored, and so the list of candidates is 134 | -- reduced. If any values /are/ removed, the callbacks registered to this 135 | -- 'Cell' will be fired. 136 | -- 137 | -- Note that, if a 'write' leaves a 'Cell' with no remaining candidates, this 138 | -- branch of the computation is deemed "unsuccessful", and we backtrack and try 139 | -- different branches until we find a successful result. 140 | -- 141 | -- We can also backtrack this operation: if something goes wrong, we restore a 142 | -- cell to its previous value. 143 | write :: Ord x => Cell x -> Set x -> Prop () 144 | write Cell{..} news = do 145 | ( olds, propagators ) <- Prim.readMutVar _ref 146 | let joined = Set.intersection news olds 147 | 148 | guard (not $ Set.null joined) 149 | 150 | unless (Set.size joined == Set.size olds) do 151 | Prim.modifyMutVar _ref (_1 .~ joined) *> propagators 152 | <|> Prim.modifyMutVar _ref (_1 .~ olds) *> empty 153 | 154 | -------------------------------------------------- 155 | 156 | -- | Initialise a map in which every cell is a 'Cell' storing the given 157 | -- possibilities. At the beginning of a WFC computation, all cells should have 158 | -- the possibility of being "any" value, and we eliminate possibilities as we 159 | -- go. 160 | initialise :: Ord x => Vect n Int -> [ x ] -> Maybe (Prop (Map_ n (Cell x))) 161 | initialise dimensions = fmap sequence . Map.create dimensions . const . fill 162 | 163 | -- | Read the collapsed values from a map. This operation is unsafe because it 164 | -- assumes every cell has exactly one remaining candidate. If there are more, 165 | -- the result will not necessarily obey the constraints given in the 166 | -- computation. If there are fewer, this will cause a runtime exception. 167 | unsafeReadMap :: Map_ n (Cell x) -> Prop (Map_ n x) 168 | unsafeReadMap = traverse (fmap Set.findMax . read) 169 | 170 | -- | State the set of possible values around the border of the map. Typically, 171 | -- this is useful if the border needs to be solid, or give the impression of an 172 | -- "island", et cetera. The function requires a vector with twice as many 173 | -- elements as the number of dimensions. These elements correspond to the 174 | -- following borders: 175 | -- 176 | -- @ 177 | -- n == 1 => [ Right, Left ] 178 | -- n == 2 => [ Right, Left, Bottom, Top ] 179 | -- n == 3 => [ Right, Left, Bottom, Top, Down, Up ] 180 | -- @ 181 | -- 182 | -- The reason is that these values should be the "opposite" to the order of the 183 | -- values returned from the user-supplied constraint function (see 'collapse' 184 | -- below). When we apply the given constraint value to a 'Nothing', the "left" 185 | -- value becomes the "right" border, the "bottom" value becomes the "top" 186 | -- border, etc. Intuitively, this is because we treat everything off the map as 187 | -- 'Nothing', so the top border is indeed "underneath" the 'Nothing' value. 188 | surround :: Ord x => Vect (Twice n) (Set x) -> Map_ n (Cell x) -> Prop () 189 | surround xs = \case 190 | Map.Axis (NonEmpty.toList -> rs) -> do 191 | let (x :. y :. zs) = xs 192 | 193 | for_ (rs ^.. _last . traverse) \cell -> write cell x 194 | for_ (rs ^.. _head . traverse) \cell -> write cell y 195 | 196 | traverse_ (surround zs) rs 197 | 198 | Map.Cell _ -> pure () 199 | 200 | -- | Find the values in the directly-neighbouring cells to a given coordinate. 201 | -- The order will be left, right, top, bottom, up, down, and "so on" (perhaps 202 | -- your 4D intuition is better than mine). This follows the order of the 203 | -- constraint function given to 'collapse', so we can zip them together. 204 | neighbours :: Map_ n x -> Vect n Int -> Vect (Twice n) (Maybe x) 205 | neighbours board@(Map.Axis rows) (x :. xs) 206 | = (board ?! pred x :. xs) 207 | :. (board ?! succ x :. xs) 208 | :. (neighbours (rows !! x) xs) 209 | neighbours (Map.Cell _) _ = Nil 210 | 211 | -- | Run a monadic action 'until' the given predicate action yields a 'True' 212 | -- value. We only need it for 'IO' (well, 'Prop'), but it's more general. 213 | until :: Monad m => m Bool -> m () -> m () 214 | until predicate action = predicate >>= \case 215 | True -> pure () 216 | False -> action *> until predicate action 217 | 218 | -- | The actual WaveFunctionCollapse implementation. I've written it in terms 219 | -- of propagators, as that's the way that makes most intuitive sense to me. 220 | -- 221 | -- Given a number of dimensions, a list of possible cell values, and a 222 | -- constraint set, produce a map of values in which the constraints are 223 | -- satisfied. The constraints are /defined/ using the third argument: the 224 | -- @connections@ function. This function should take a value (which, if it's 225 | -- not on the map, will be @Nothing@), and return the values that are allowed 226 | -- to be placed next to it. These values are ordered as left, right, top, 227 | -- bottom, up, down... and so on, into dimensions I can't visualise. 228 | -- 229 | -- If you're curious, see the source code for in-line explanations of what's 230 | -- going on. 231 | collapse 232 | :: forall n x 233 | . Applicative (Vect (Twice n)) 234 | => Ord x 235 | => Vect n Int 236 | -> [ x ] 237 | -> (Maybe x -> Vect (Twice n) (Set x)) 238 | -> Prop (Map_ n x) 239 | 240 | collapse dimensions candidates connections = do 241 | 242 | -- First, we create a map where every cell contains a 'Cell'. Each 'Cell', 243 | -- initially, will have the possibility of being /any/ of the given 244 | -- candidates. Hopefully, many of these candidates will be eliminated as we 245 | -- start collapsing. 246 | initial <- fromMaybe empty (initialise dimensions candidates) 247 | 248 | -- We pass 'Nothing' to the @connections@ function, to return the neighbours 249 | -- of a cell off the map. The left neighbour of 'Nothing' is therefore the 250 | -- /right/ border of the map. The neighbour above 'Nothing' is the /bottom/ 251 | -- border of the map, and so on. 252 | surround (connections Nothing) initial 253 | 254 | -- Now, we set up the constraints for each cell on the map. The neat thing 255 | -- about the propagator model is we can express operations in terms of each 256 | -- cell and its neighbours, rather than trying to keep track of this 257 | -- "globally". 258 | ifor_ initial \position cell -> do 259 | 260 | -- The immediate neighbours of a cell are the only things it can directly 261 | -- affect in this formulation of the algorithm. 262 | let targets = neighbours initial position 263 | 264 | watch cell \(Set.toList -> current) -> do 265 | 266 | -- This might look a bit confusing, so we'll break it down. @current@ 267 | -- here is a list of all remaining possibilities within a given cell. For 268 | -- each of these possibilities, we figure out all the possible 269 | -- neighbouring values. Then, we union together all the possibilities for 270 | -- each neighbour across all the candidates. 271 | -- 272 | -- In other words, if any value in this cell allows a particular value in 273 | -- a particular neighbour, then that value is still a possibility. If 274 | -- none of the remaining values allow that value, then that value can be 275 | -- eliminated from the cell. 276 | let neighbourUpdates 277 | = fmap (foldl1 Set.union) 278 | . traverse (connections . Just) -- TODO: check this, it might have broken things 279 | $ current 280 | 281 | zipWithA_ (traverse_ . flip write) neighbourUpdates targets 282 | 283 | let shuffle :: forall a. [ a ] -> Prop [ a ] 284 | shuffle = liftIO . Gen.generate . Gen.shuffle 285 | 286 | -- This is definitely not the most efficient way to check whether the map 287 | -- has collapsed (ideally, you'd use a queue to keep track of which cells 288 | -- have and haven't collapsed), but I've done it this way just so we 289 | -- don't distract too much from the core implementation. A map has 290 | -- collapsed if all cells have been whittled down to having only one 291 | -- remaining possibility. 292 | collapsed :: Prop Bool 293 | collapsed = fmap (all \x -> Set.size x == 1) (traverse read initial) 294 | 295 | -- Now we've specified all the constraints, the idea is that we find the set 296 | -- of "most collapsed but not yet fully collapsed" cells (e.g. all the cells 297 | -- that contain the joint-lowest number of possibilities), pick one of these 298 | -- cells at random, and collapse it to a random remaining possibility. This 299 | -- should trigger more neighbouring collapse, and we repeat this process 300 | -- until we've hit a collapsed state. 301 | until collapsed do 302 | snapshot <- traverse read initial 303 | 304 | -- Each coordinate and its number of remaining candidates. 305 | let sizes :: [( Vect n Int, Int )] 306 | sizes = snapshot ^@.. itraversed . to Set.size 307 | 308 | -- All coordinates (and their sizes) that haven't yet collapsed. 309 | uncollapsed :: [( Vect n Int, Int )] 310 | uncollapsed = filter ((/= 1) . snd) sizes 311 | 312 | -- All coordinates grouped by how many remaining candidates they have 313 | -- (in ascending order). 314 | remainders :: [[( Vect n Int, Int )]] 315 | remainders = groupWith snd (sortWith snd uncollapsed) 316 | 317 | -- The set of coordinates with the join lowest number of remaining 318 | -- candidates (that haven't already collapsed). @head@ is safe here as 319 | -- our @until collapsed@ check guarantees there's a non-zero number of 320 | -- "uncollapsed" candidates remaining. 321 | focus :: [ Vect n Int ] 322 | focus = map fst (head remainders) 323 | 324 | -- We shuffle the candidates, and try collapsing the first. If that doesn't 325 | -- work, we try collapsing the second, and so on. We can backtrack along 326 | -- the list of coordinates until we find one that results in a successful 327 | -- collapse, and we have our answer! 328 | shuffle focus >>= asum . map \coordinate -> 329 | case initial ?! coordinate of 330 | Just cell -> do 331 | 332 | -- Read all the possible values, shuffle them, and then try each 333 | -- remaining value in turn until we find a successful collapse. 334 | values <- read cell >>= shuffle . Set.toList 335 | asum (fmap (write cell . Set.singleton) values) 336 | 337 | Nothing -> -- This should be impossible. 338 | pure () 339 | 340 | -- Now the map has collapsed, and we haven't at some point hit an 'empty' due 341 | -- to a cell with no remaining candidates, this operation is safe. We can 342 | -- read the single remaining candidate from each cell, and finally produce 343 | -- our collapsed map. Hooray! 344 | unsafeReadMap initial 345 | 346 | -------------------------------------------------- 347 | 348 | -- A little convenience using "GHC.TypeLits". If you statically know how many 349 | -- dimensions you're working with, this means you can use numeric literals in 350 | -- your type, which is a bit tidier. 351 | type Connections (n :: TL.Nat) (x :: Type) 352 | = Vect (Unarise n) x 353 | 354 | -- | Just like 'Map.pos', but for vectors of any type. You're most likely only 355 | -- going to need this for your constraint function, though. 356 | connect :: forall n x k. Make (Unarise n) x k => k 357 | connect = make @(Unarise n) 358 | --------------------------------------------------------------------------------