terminal-3d-graphics (empty) → 0.2.0.0
raw patch · 29 files changed
+1865/−0 lines, 29 filesdep +arraydep +basedep +bytestringbinary-added
Dependencies added: array, base, bytestring, comonad, deepseq, parallel, process, terminal-3d-graphics, transformers
Files
- LICENSE +24/−0
- README.md +58/−0
- app/Main.hs +118/−0
- src/Terminal3D.hs +49/−0
- src/Terminal3D/BigText.hs +376/−0
- src/Terminal3D/Lighting.hs +31/−0
- src/Terminal3D/Localization.hs +60/−0
- src/Terminal3D/Loop.hs +130/−0
- src/Terminal3D/Matrix.hs +90/−0
- src/Terminal3D/Movement.hs +46/−0
- src/Terminal3D/Objects.hs +253/−0
- src/Terminal3D/TerminalGraphics.hs +167/−0
- src/Terminal3D/Textures.hs +63/−0
- src/Terminal3D/Tri.hs +222/−0
- src/Terminal3D/Vector.hs +104/−0
- terminal-3d-graphics.cabal +74/−0
- textures/cube.bmp binary
- textures/floor.bmp binary
- textures/grass.bmp binary
- textures/lava.bmp binary
- textures/leaf.bmp binary
- textures/portalBlue.bmp binary
- textures/portalOrange.bmp binary
- textures/rock.bmp binary
- textures/sky.bmp binary
- textures/trunk.bmp binary
- textures/wall.bmp binary
- textures/wallpaper.bmp binary
- textures/woodFloor.bmp binary
+ LICENSE view
@@ -0,0 +1,24 @@+This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to <https://unlicense.org>
+ README.md view
@@ -0,0 +1,58 @@+# Terminal3DGraphics + +This is a little 3D engine written in Haskell that draws straight into your terminal. You can walk around the scene with keyboard input, and it all renders in true-colour using ANSI half-block characters (▀), which lets each character cell show two stacked "pixels". This works on both Linux and Windows and also exports as a library if anyone wants to make custom 3D worlds. + + + + + + + +# Features + + - Movement around the worlds is done via entering keys on the keyboard and pressing enter. + - Allows for Portals with recursive views through + - Allows for selections of post processing and super sampling anti-aliasing + - Has multiple demo worlds + - Translations are selectable in the program + - Allows customizable screen size + - Pipelines auto-build versions for X64 Linux and Windows + +## Building the demo + +To build with Cabal and have it actually run quickly + +```bash +cabal build all +cabal run t3d +``` + +To run with the interpreter + +```bash +ghci -isrc -iapp -package parallel -package bytestring -package transformers -package array -package deepseq -package comonad -package process app/Main.hs +:main +``` + +## Using as a library + +Add to your `your-project.cabal`: + +```cabal +build-depends: terminal-3d-graphics +``` + +Then in your Haskell source: + +```haskell +import Terminal3D +import Control.Monad.Trans.State (evalStateT) + +main :: IO () +main = do + tex <- readBMP "myTexture.bmp" + let tris = cubeFormer (texWallFormer tex) + lights = [Ray (Vec3 0.5 1 0.5), Ambient 0.3] + world = World (map (bakeLight lights) tris) Nothing + evalStateT (loop world) def +```
+ app/Main.hs view
@@ -0,0 +1,118 @@+module Main where++import Terminal3D+import Control.Monad.Trans.State (evalStateT)++-- | A world with a portal on the side of each wall+portalWorld :: IO World+portalWorld = do+ [cubeTexture, wallTexture, floorTexture, portalOrangeTexture, portalBlueTexture]+ <- mapM readBMP [ "textures/cube.bmp", "textures/wall.bmp", "textures/floor.bmp", "textures/portalOrange.bmp", "textures/portalBlue.bmp" ]+ let cube = (fmap . fmap) (+ Vec3 20 (-15) 15) (cubeFormer (texWallFormer cubeTexture))+ room = roomFormer (Vec3 (-30) (-35) (-60)) (Vec3 70 35 65) (texWallFormer floorTexture) (texWallFormer wallTexture)+ portalMin = Vec3 (-28) (-25) (-25)+ portalMax = Vec3 68 20 25+ portal = portalFormer (texWallFormer portalBlueTexture) (texWallFormer portalOrangeTexture)+ ( comp3Reduce portalMin portalMin portalMax, comp3Reduce portalMin portalMax portalMin )+ ( comp3Reduce portalMax portalMin portalMax, comp3Reduce portalMax portalMax portalMin )+ False+ lights = [Ray (Vec3 0.25 0.25 0.25), Ambient 0.5]+ pure (World (bakeLight lights <$> concat [cube, room, portal]) (Just (-25, 65, -55, 60)))++-- | A world with a portal on the side of each wall+chessWorld :: IO World+chessWorld = do+ let tileTris i j =+ let fi = fromIntegral i+ fj = fromIntegral j+ (v0, v1, v2, v3) = ( Vec3 fi 0 fj, Vec3 (fi + 1) 0 fj, Vec3 (fi + 1) 0 (fj + 1), Vec3 fi 0 (fj + 1) )+ col = if even (i + j) then Solid RGB { red = 250, green = 250, blue = 250 }+ else Solid RGB { red = 0, green = 0, blue = 0 }+ in [ Tri v0 v1 v2 col, Tri v0 v2 v3 col ]+ board = concat [ tileTris i j | i <- [0 :: Int .. 8], j <- [0 :: Int .. 8] ]+ movedBoard = (fmap . fmap) ((+ Vec3 (-5) (-10) (-5)) . (* 5)) board+ skyBlue = RGB { red = 0, green = 0, blue = 250 }+ room = roomFormer (Vec3 (-100) (-100) (-100)) (Vec3 100 100 100) (solWallFormer skyBlue) (solWallFormer skyBlue)+ pure (World ((bakeLight [Ambient 0.5] <$> movedBoard) ++ room) (Just (-95, 95, -95, 95)))++-- | A world with a portal on the side of each wall+islandWorld :: IO World+islandWorld = do+ [trunkTexture, leafTexture, grassTexture, rockTexture]+ <- mapM readBMP [ "textures/trunk.bmp", "textures/leaf.bmp", "textures/grass.bmp", "textures/rock.bmp" ]+ let+ tree = treeFormer (texWallFormer trunkTexture) (texWallFormer leafTexture)+ lights = [Ray (Vec3 0.25 0.25 0.25), Ambient 0.5]+ island = islandFormer 20 30 (texWallFormer rockTexture) (texWallFormer grassTexture)+ shiftedWorld = (fmap . fmap) (+ Vec3 (-5) (-10) (-5)) (island ++ tree)+ pure (World (bakeLight lights <$> shiftedWorld) Nothing)++-- | A world with a big castle surrounded by trees on a grassy field+castleWorld :: IO World+castleWorld = do+ [trunkTexture, leafTexture, grassTexture]+ <- mapM readBMP [ "textures/trunk.bmp", "textures/leaf.bmp", "textures/grass.bmp" ]+ let rgb r g b = RGB { red = r, green = g, blue = b }+ lights = [Ray (Vec3 0.25 0.25 0.25), Ambient 0.5]+ castle = (fmap . fmap) ((+ Vec3 0 (-30) 250) . (* 3)) (castleFormer (solWallFormer (rgb 150 150 150)) (solWallFormer (rgb 180 30 30)))+ tree = treeFormer (texWallFormer trunkTexture) (texWallFormer leafTexture)+ treeAt (x, z) = (fmap . fmap) ((+ Vec3 x (-14) z) . (* 4)) tree+ trees = concatMap treeAt+ [ (-260, 100), (-160, 100), (160, 100), (260, 100)+ , (-210, 180), (-240, 260), (-210, 340)+ , (210, 180), (240, 260), (210, 340)+ , (-150, 420), (-50, 430), (50, 430), (150, 420)+ ]+ room = roomFormer (Vec3 (-400) (-30) (-100)) (Vec3 400 250 480) (tiledFormer 20 15 (texWallFormer grassTexture)) (solWallFormer (rgb 100 180 250))+ pure (World ((bakeLight lights <$> (castle ++ trees)) ++ room) (Just (-395, 395, -95, 475)))++-- | A world on fire: campfires around a brick room with a river of lava running through it+fireWorld :: IO World+fireWorld = do+ [logTexture, brickTexture, rockTexture, lavaTexture]+ <- mapM readBMP [ "textures/trunk.bmp", "textures/wall.bmp", "textures/rock.bmp", "textures/lava.bmp" ]+ let rgb r g b = RGB { red = r, green = g, blue = b }+ campfire = fireFormer (texWallFormer logTexture) (solWallFormer (rgb 220 30 0)) (solWallFormer (rgb 255 140 0)) (solWallFormer (rgb 255 230 50))+ fireAt (x, z) = (fmap . fmap) (+ Vec3 x (-30) z) campfire+ fires = concatMap fireAt [ (70, -70), (70, 50), (-85, -65), (-85, 65), (0, 70) ]+ lava = (fmap . fmap) (+ Vec3 0 (-29.5) 0) (lavaFormer (texWallFormer lavaTexture))+ room = roomFormer (Vec3 (-100) (-30) (-100)) (Vec3 100 100 100) (tiledFormer 8 8 (texWallFormer rockTexture)) (tiledFormer 5 3 (texWallFormer brickTexture))+ pure (World (fires ++ lava ++ room) (Just (-95, 95, -95, 95)))++-- | A world with a teapot on the floor+teapotWorld :: IO World+teapotWorld = do+ [woodTexture, wallpaperTexture] <- mapM readBMP [ "textures/woodFloor.bmp", "textures/wallpaper.bmp" ]+ let rgb r g b = RGB { red = r, green = g, blue = b }+ lights = [Ray (Vec3 0.25 0.25 0.1), Ambient 0.5]+ teapot = (fmap . fmap) (+ Vec3 0 (-30) 30) (teapotFormer (solWallFormer (rgb 240 240 240)) (solWallFormer (rgb 30 90 200)))+ room = roomFormer (Vec3 (-100) (-30) (-100)) (Vec3 100 100 100) (tiledFormer 8 8 (texWallFormer woodTexture)) (tiledFormer 5 3 (texWallFormer wallpaperTexture))+ pure (World (bakeLight lights <$> (teapot ++ room)) (Just (-95, 95, -95, 95))) ++-- | A world with a rainbow over a field+rainbowWorld :: IO World+rainbowWorld = do+ [grassTexture, skyTexture] <- mapM readBMP [ "textures/grass.bmp", "textures/sky.bmp" ]+ let rgb r g b = RGB { red = r, green = g, blue = b }+ colours = [ rgb 255 0 0, rgb 255 127 0, rgb 255 255 0, rgb 0 200 0, rgb 0 0 255, rgb 75 0 130, rgb 148 0 211 ]+ rainbow = (fmap . fmap) (+ Vec3 0 (-30) 0) (rainbowFormer (solWallFormer <$> colours))+ room = roomFormer (Vec3 (-100) (-30) (-100)) (Vec3 100 100 100) (tiledFormer 8 8 (texWallFormer grassTexture)) (texWallFormer skyTexture)+ pure (World ((fmap . fmap) (+ Vec3 0 0 70) (rainbow ++ room)) (Just (-95, 95, -25, 165)))++-- | A list of all of the demo worlds to show off, and a corresponding name+demoWorlds :: [(String, IO World)]+demoWorlds = [ ("portal", portalWorld), ("chess", chessWorld), ("island", islandWorld), ("castle", castleWorld), ("fire", fireWorld), ("teapot", teapotWorld), ("rainbow", rainbowWorld)]++-- | A function that prompts the user with a list of demo worlds and has them enter a number to choose one. It then returns that demo world+chooseDemoWorld :: IO World+chooseDemoWorld = do+ putStrLn "Choose an option:"+ mapM_ putStrLn $ zipWith (++) (map (\n -> show n ++ " - ") ([1..] :: [Int])) (fst <$> demoWorlds)+ readLn >>= \n ->+ if n >= 1 && n <= length demoWorlds+ then snd (demoWorlds !! (n - 1))+ else putStrLn "Invalid choice, try again." >> chooseDemoWorld++-- | Entry point+main :: IO ()+main = do chooseDemoWorld >>= flip (evalStateT . loop) ( def :: AppState )
+ src/Terminal3D.hs view
@@ -0,0 +1,49 @@+{-| +Module : Terminal3D +Description : A simple terminal 3D rasteriser with textures, portals, and lighting. +Stability : experimental + +Re-exports every public sub-module so library users only need one import: + +> import Terminal3D + +== Quick-start + +@ +import Terminal3D +import Control.Monad.Trans.State (evalStateT) + +main :: IO () +main = do + tex <- readBMP "myTexture.bmp" + let tris = cubeFormer (texWallFormer tex) + lights = [Ray (Vec3 0.5 1 0.5), Ambient 0.3] + world = World (map (bakeLight lights) tris) Nothing + evalStateT (loop world) def +-} +module Terminal3D + ( -- * Re-exports + module Terminal3D.Vector + , module Terminal3D.Matrix + , module Terminal3D.Textures + , module Terminal3D.Tri + , module Terminal3D.Lighting + , module Terminal3D.TerminalGraphics + , module Terminal3D.Objects + , module Terminal3D.BigText + , module Terminal3D.Movement + , module Terminal3D.Loop + , module Terminal3D.Localization + ) where + +import Terminal3D.Vector +import Terminal3D.Matrix +import Terminal3D.Textures +import Terminal3D.Tri +import Terminal3D.Lighting +import Terminal3D.TerminalGraphics +import Terminal3D.Objects +import Terminal3D.BigText +import Terminal3D.Movement +import Terminal3D.Loop +import Terminal3D.Localization
+ src/Terminal3D/BigText.hs view
@@ -0,0 +1,376 @@+module Terminal3D.BigText where + +import Data.Char + +-- | Given a screen resolution in pixels, this will return an appropriate text size to use +getTextSize :: (Int, Int) -> Int +getTextSize (w, _) = quot w 1000 + +-- | Print big text at a given scale. +printBig :: Int -> String -> IO () +printBig 0 msg = putStrLn msg +printBig scale msg = mapM_ putStrLn rows + where + chars = map (glyph . toUpper) msg + rows = concatMap expandRow [0..6] + expandRow r = replicate scale $ concatMap (\g -> expandCol (g !! r) ++ replicate scale ' ') chars + expandCol = concatMap (replicate (scale * 2)) + +-- | Glyphs are 5 wide x 7 tall for better letter clarity. +glyph :: Char -> [String] +glyph c = case c of + 'A' -> [" ▒ ", + " ▒█▒ ", + "▒█ █▒", + "█████", + "█░ ░█", + "█ █", + "▀ ▀"] + + 'B' -> ["████ ", + "█░ ░█", + "█░ ░█", + "████ ", + "█░ ░█", + "█░ ░█", + "████ "] + + 'C' -> [" ▒███", + "▒█░ ", + "█░ ", + "█ ", + "█░ ", + "▒█░ ", + " ▒███"] + + 'D' -> ["████ ", + "█░ ░█", + "█ █", + "█ █", + "█ █", + "█░ ░█", + "████ "] + + 'E' -> ["█████", + "█░ ", + "█░ ", + "████ ", + "█░ ", + "█░ ", + "█████"] + + 'F' -> ["█████", + "█░ ", + "█░ ", + "████ ", + "█░ ", + "█░ ", + "█ "] + + 'G' -> [" ▒███", + "▒█░ ", + "█░ ", + "█ ██", + "█ ░█", + "▒█░░█", + " ▒███"] + + 'H' -> ["█ █", + "█ █", + "█ █", + "█████", + "█ █", + "█ █", + "█ █"] + + 'I' -> ["█████", + " █ ", + " █ ", + " █ ", + " █ ", + " █ ", + "█████"] + + 'J' -> [" ███", + " █ ", + " █ ", + " █ ", + "█ █ ", + "█ ░█ ", + " ███ "] + + 'K' -> ["█ █", + "█ ▒█", + "█ ▒█ ", + "███ ", + "█ ▒█ ", + "█ ▒█", + "█ █"] + + 'L' -> ["█ ", + "█ ", + "█ ", + "█ ", + "█ ", + "█░ ", + "█████"] + + 'M' -> ["█ █", + "██ ██", + "█▒█▒█", + "█ █ █", + "█ █", + "█ █", + "█ █"] + + 'N' -> ["█ █", + "██ █", + "█▒ █", + "█ █ █", + "█ ▒█", + "█ ██", + "█ █"] + + 'O' -> [" ███ ", + "▒█ █▒", + "█ █", + "█ █", + "█ █", + "▒█ █▒", + " ███ "] + + 'P' -> ["████ ", + "█░ ░█", + "█░ ░█", + "████ ", + "█ ", + "█ ", + "█ "] + + 'Q' -> [" ███ ", + "▒█ █▒", + "█ █", + "█ █", + "█ █ █", + "▒█ ██", + " ████"] + + 'R' -> ["████ ", + "█░ ░█", + "█░ ░█", + "████ ", + "█ ▒ ", + "█ ▒ ", + "█ █"] + + 'S' -> [" ████", + "▒█ ", + "▒█ ", + " ███ ", + " █▒", + " █▒", + "████ "] + + 'T' -> ["█████", + " ░█░ ", + " █ ", + " █ ", + " █ ", + " █ ", + " █ "] + + 'U' -> ["█ █", + "█ █", + "█ █", + "█ █", + "█ █", + "▒█ █▒", + " ███ "] + + 'V' -> ["█ █", + "█ █", + "█ █", + "▒█ █▒", + " █ █ ", + " ▒█▒ ", + " █ "] + + 'W' -> ["█ █", + "█ █", + "█ █", + "█ █ █", + "█▒█▒█", + "██ ██", + "█ █"] + + 'X' -> ["█ █", + " ▒ ▒ ", + " ▒█▒ ", + " █ ", + " ▒█▒ ", + " ▒ ▒ ", + "█ █"] + + 'Y' -> ["█ █", + " ▒ ▒ ", + " ▒█▒ ", + " █ ", + " █ ", + " █ ", + " █ "] + + 'Z' -> ["█████", + " ▒█", + " ▒█ ", + " ░█░ ", + " █▒ ", + "█▒ ", + "█████"] + + '0' -> [" ███ ", + "▒█ █▒", + "█ ██", + "█ █ █", + "██ █", + "▒█ █▒", + " ███ "] + + '1' -> [" █ ", + " ██ ", + "░ █ ", + " █ ", + " █ ", + " █ ", + "█████"] + + '2' -> [" ███ ", + "▒█ █▒", + " ▒█", + " ██ ", + " █▒ ", + "▒█ ", + "█████"] + + '3' -> ["████ ", + " ░█", + " ░█", + " ███ ", + " ░█", + " ░█", + "████ "] + + '4' -> ["█ █ ", + "█ █ ", + "█ █ ", + "█████", + " █ ", + " █ ", + " █ "] + + '5' -> ["█████", + "█░ ", + "█░ ", + "████ ", + " ░█", + " ░█", + "████ "] + + '6' -> [" ███ ", + "▒█ ", + "█░ ", + "████ ", + "█ █", + "▒█ █▒", + " ███ "] + + '7' -> ["█████", + " ░█", + " ░█ ", + " █ ", + " █░ ", + " █ ", + " █ "] + + '8' -> [" ███ ", + "▒█ █▒", + "▒█ █▒", + " ███ ", + "▒█ █▒", + "▒█ █▒", + " ███ "] + + '9' -> [" ███ ", + "▒█ █▒", + "█ █", + " ████", + " ░█", + " ░█▒", + " ███ "] + + ' ' -> [" ", + " ", + " ", + " ", + " ", + " ", + " "] + + '!' -> [" █ ", + " █ ", + " █ ", + " ▒ ", + " ", + " ░ ", + " █ "] + + '?' -> [" ███ ", + "▒█ █▒", + " ░█", + " ▒█ ", + " █ ", + " ", + " █ "] + + '.' -> [" ", + " ", + " ", + " ", + " ", + " ", + " █ "] + + ',' -> [" ", + " ", + " ", + " ", + " ", + " ▒ ", + " ▒ "] + '-' -> [" ", + " ", + " ", + "█████", + " ", + " ", + " "] + ':' -> [" ", + " █ ", + " ▒ ", + " ", + " ▒ ", + " █ ", + " "] + '/' -> [" █", + " ▒█", + " █ ", + " █░ ", + " █ ", + "█▒ ", + "█ "] + _ -> ["█████", + "█ █", + "█ ? █", + "█ █", + "█████", + " ", + " "]
+ src/Terminal3D/Lighting.hs view
@@ -0,0 +1,31 @@+module Terminal3D.Lighting where + +import Terminal3D.Tri +import Terminal3D.Textures +import Terminal3D.Vector + +-- | A light source: either a directional ray or a uniform ambient term +data Light vec = Ray vec | Ambient Double + +-- | Pre-bake lighting onto a triangle by scaling all its colour values +bakeLight :: [Light Vec3] -> Tri Vec3 -> Tri Vec3 +bakeLight lights tri@(Tri v1 v2 v3 colorMap) = + case colorMap of + Solid rgb -> + Tri v1 v2 v3 (Solid (brightMap (*mult) rgb)) + Texture (TextureMapping tex uvA uvB uvC) -> + let bakedTex = fmap (brightMap (*mult)) tex + in Tri v1 v2 v3 (Texture (TextureMapping bakedTex uvA uvB uvC)) + Portal v1b v2b v3b rotMat -> + Tri v1 v2 v3 (Portal v1b v2b v3b rotMat) + where + norm = getNorm tri + mult = getNetBright lights norm + +-- | Compute net surface brightness given a list of lights and a surface normal +getNetBright :: Vector vec => [Light vec] -> vec -> Double +getNetBright lights surfNorm = + let n = signum surfNorm + contrib (Ray dir) = max 0 (dot n (signum dir)) + contrib (Ambient amb) = amb + in sum (map contrib lights)
+ src/Terminal3D/Localization.hs view
@@ -0,0 +1,60 @@+module Terminal3D.Localization where + +data Local = Local { english :: String, spanish :: String, latin :: String, german :: String } deriving (Show, Eq) + +appstatePosition, appstateRotation, appstateProjection, appstateScreenSize, appstateSSAA, appstatePPAA, appstateLanguage :: Local +appstatePosition = Local "Position" "Posicion" "Positio" "Position" +appstateRotation = Local "Rotation" "Rotacion" "Rotatio" "Rotation" +appstateProjection = Local "Projection" "Proyeccion" "Proiectio" "Projektion" +appstateScreenSize = Local "ScreenSize" "Pantalla" "MagnitudoTabulae" "Bildschirmgroesse" +appstateSSAA = Local "SSAA" "SSAA" "SSAA" "SSAA" +appstatePPAA = Local "PPAA" "PPAA" "PPAA" "PPAA" +appstateLanguage = Local "Language" "Idioma" "Lingua" "Sprache" + +commandQuit, commandHelp :: Local +commandQuit = Local "quit" "salir" "exi" "beenden" +commandHelp = Local "help" "ayuda" "auxilium" "hilfe" + +inputTypeGaussian, inputTypeBox, inputTypeNone, inputTypeWidth, inputTypeHeight :: Local +inputTypeGaussian = Local "Gaussian" "Gaussiano" "Gaussianus" "Gauss" +inputTypeBox = Local "box" "caja" "capsa" "Box" +inputTypeNone = Local "none" "ninguno" "nullus" "keine" +inputTypeWidth = Local "width" "ancho" "latitudo" "Breite" +inputTypeHeight = Local "height" "alto" "altitudo" "Hoehe" + +inputTypeProjection, inputTypeAffine :: Local +inputTypeProjection = Local "projection" "proyeccion" "proiectio" "Projektion" +inputTypeAffine = Local "affine" "afin" "affinis" "affin" + +feedbackGoodbye, feedbackUnknownCommand, feedbackHelpUnknownCommand, feedbackStartText, feedbackUsage, feedbackPositiveIntegers, feedbackInteger :: Local +feedbackGoodbye = Local "Goodbye." "Adios." "Vale." "Auf Wiedersehen." +feedbackUnknownCommand = Local "Unknown command" "Comando desconocido" "Mandatum ignotum" "Unbekannter Befehl" +feedbackHelpUnknownCommand = Local "Try '?' for help." "Prueba '?' para ver la ayuda." "Tempta '?' ad auxilium." "Versuche '?' fuer Hilfe." +feedbackStartText = Local "Command (or help/quit)" "Comando (o ayuda/salir)" "Mandatum (vel auxilium/exi)" "Befehl (oder hilfe/beenden)" +feedbackUsage = Local "Usage" "Uso" "Usus" "Verwendung" +feedbackPositiveIntegers = Local "Must be Positive Integers" "Deben ser enteros positivos" "Debent esse numeri integri positivi" "Muessen positive ganze Zahlen sein" +feedbackInteger = Local "Not a valid integer" "No es un entero valido" "Non est numerus integer validus" "Keine gueltige ganze Zahl" + +commandDoNothing, commandForward, commandBackward, commandLeft, commandRight :: Local +commandDoNothing = Local "do nothing" "no hacer nada" "nihil agere" "nichts tun" +commandForward = Local "move forward" "avanzar" "progredi" "vorwaerts bewegen" +commandBackward = Local "move backward" "retroceder" "regredi" "rueckwaerts bewegen" +commandRight = Local "strafe right" "desplazarse a la derecha" "ad dextram transire" "seitlich nach rechts bewegen" +commandLeft = Local "strafe left" "desplazarse a la izquierda" "ad sinistram transire" "seitlich nach links bewegen" + +commandTurnLeft, commandTurnRight, commandTurnUp, commandTurnDown :: Local +commandTurnLeft = Local "turn left" "girar a la izquierda" "ad sinistram vertere" "nach links drehen" +commandTurnRight = Local "turn right" "girar a la derecha" "ad dextram vertere" "nach rechts drehen" +commandTurnUp = Local "turn up" "girar hacia arriba" "sursum vertere" "nach oben drehen" +commandTurnDown = Local "turn down" "girar hacia abajo" "deorsum vertere" "nach unten drehen" + +data Language = Language { langName :: Local, langPick :: Local -> String } + +langEnglish, langSpanish, langLatin, langGerman :: Language +langEnglish = Language (Local "English" "Ingles" "Anglica" "Englisch") english +langSpanish = Language (Local "Spanish" "Espanol" "Hispanica" "Spanisch") spanish +langLatin = Language (Local "Latin" "Latin" "Latina" "Latein") latin +langGerman = Language (Local "German" "Aleman" "Germanica" "Deutsch") german + +allLanguages :: [Language] +allLanguages = [ langEnglish, langSpanish, langLatin, langGerman ]
+ src/Terminal3D/Loop.hs view
@@ -0,0 +1,130 @@+module Terminal3D.Loop where + +import Terminal3D.Vector +import Terminal3D.Tri + +import Control.Monad.Trans.State +import Terminal3D.TerminalGraphics +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString.Lazy as LazyByteBuilder +import System.IO (hFlush, stdout) +import System.Exit (exitSuccess) +import Terminal3D.Matrix ( rotationMatrix ) +import Terminal3D.Movement +import Terminal3D.BigText +import System.Process (callCommand) +import System.Info (os) +import Control.Monad (when) +import Terminal3D.Localization +import Data.Char +import Data.List + +-- | (cameraPosition, cameraRotation, projection, screenSize, Supersampling Anti-Aliasing, Post Processing Anti-Aliasing) +newtype AppState = AppState (Vec3, Vec3, Projection, (Int, Int), AntiAliasing, AntiAliasing, Language) + +instance Default AppState where + def = AppState ( 0, 0, Perspective, (100, 50), def, def, langEnglish ) + + +instance Show AppState where + show (AppState (pos, rot, proj, screenSize, ssaa, ppaa, language)) = + unlines (map showProperty properties) + where + translator :: (Local -> String) + translator = langPick language + showProperty :: (String, String) -> String + showProperty (label, value) = label ++ concat (replicate (spacesToColon - length label) " ") ++ ": " ++ value + properties :: [(String, String)] + properties = [ + (translator appstatePosition, show pos), + (translator appstateRotation, show rot), + (translator appstateProjection, displayProjection translator proj), + (translator appstateScreenSize, show screenSize), + (translator appstateSSAA, dispalyAntiAliasing translator ssaa), + (translator appstatePPAA, dispalyAntiAliasing translator ppaa), + (translator appstateLanguage, translator $ langName language) + ] + spacesToColon :: Int + spacesToColon = maximum $ map (length . fst) properties + +-- | Parses user input for changing anti-aliasing settings +parseAA :: [String] -> (Local -> String) -> Either String AntiAliasing +parseAA [kind, n] translator + | kind == translator inputTypeBox = case reads n of { [(i, "")] -> Right (aaBox i); _ -> Left (translator feedbackInteger ++ ": " ++ n) } + | kind == translator inputTypeGaussian = case reads n of { [(i, "")] -> Right (aaGaussian i); _ -> Left (translator feedbackInteger ++ ": " ++ n) } +parseAA _ translator = Left $ translator feedbackUsage ++ ": " ++ translator inputTypeNone ++ " | " ++ translator inputTypeBox ++ " <n> | " ++ translator inputTypeGaussian ++ " <n>" + +-- | Parses user input for changing the screen size +parseSize :: [String] -> (Local -> String) -> Either String (Int, Int) +parseSize [w, h] translator = case (reads w, reads h) of + ([(w', "")], [(h', "")]) | w' > 0 && h' > 0 -> Right (w', h') + _ -> Left $ translator feedbackPositiveIntegers +parseSize _ translator = Left $ translator feedbackUsage ++ ":" ++ " " ++ translator appstateScreenSize ++ " <" ++ translator inputTypeWidth ++ "> <" ++ translator inputTypeHeight ++ ">" + +-- | Parses user input for changing the screen size +parseLang :: [String] -> (Local -> String) -> Either String Language +parseLang args translator = case args of + [lang] | Just l <- find (matches lang) allLanguages -> Right l + _ -> Left $ translator feedbackUsage ++ ": " ++ translator appstateLanguage + ++ " <" ++ intercalate " | " (map (translator . langName) allLanguages) ++ ">" + where + matches lang l = map toLower (translator (langName l)) == map toLower lang + +-- | Return a help string listing all available commands. +helpText :: (Local -> String) -> String +helpText translator = + let aaFields = [translator appstateSSAA, translator appstatePPAA] + in unlines $ + map (\(MoveOperation _ _ c name) -> " " ++ [c] ++ " " ++ translator name) moveOperations ++ + [ unwords (map (((label ++ " ") ++ ) . (++ " <n>") . translator . aaName . ($ 0)) aaMethods) | label <- aaFields ] ++ + [ translator appstateScreenSize ++ " <w> <h>" ] + +-- | A world's triangles plus optional walls the camera can't leave +data World = World + { worldTris :: [Tri Vec3] + , worldBounds :: Maybe Bounds + } + +-- | Main render/input loop. +loop :: World -> StateT AppState IO () +loop world = do + liftIO $ when (os == "mingw32") $ callCommand "chcp 65001" -- Force UTF8 output on Windows. Hackish + appState@(AppState (currentPos, currentRot, projection, screenSize, ssaa, ppaa, _)) <- get + liftIO clearScreen + let tris = worldTris world + rotMat = rotationMatrix currentRot + ntcTris = posRotToNtcTris tris (currentPos, rotMat) + textSize = getTextSize screenSize + liftIO $ LazyByteBuilder.hPut stdout (getScreen ntcTris screenSize projection tris rotMat ssaa ppaa) + liftIO $ printBig textSize (show appState) + promptLoop world + +-- | A loop for prompting the user for what input to do +promptLoop :: World -> StateT AppState IO () +promptLoop world = do + AppState (currentPos, currentRot, _, screenSize, _, _, language) <- get + let textSize = getTextSize screenSize + translator = langPick language + liftIO $ putStr (translator feedbackStartText ++ ": ") + liftIO $ hFlush stdout + cmd <- liftIO getLine + case words cmd of + (ssaaWord : rest) | ssaaWord == translator appstateSSAA -> case parseAA rest translator of + Right newAA -> modify (\(AppState (p, r, pr, s, _, pp, lang)) -> AppState (p, r, pr, s, newAA, pp, lang)) >> loop world + Left err -> liftIO (printBig textSize err) >> promptLoop world + (ppaaWord : rest) | ppaaWord == translator appstatePPAA -> case parseAA rest translator of + Right newAA -> modify (\(AppState(p, r, pr, s, sp, _, lang)) -> AppState (p, r, pr, s, sp, newAA, lang)) >> loop world + Left err -> liftIO (printBig textSize err) >> promptLoop world + (screenSizeWord : rest) | screenSizeWord == translator appstateScreenSize -> case parseSize rest translator of + Right newSize -> modify (\(AppState (p, r, pr, _, sp, pp, lang)) -> AppState (p, r, pr, newSize, sp, pp, lang)) >> loop world + Left err -> liftIO (printBig textSize err) >> promptLoop world + (langWord : rest) | langWord == translator appstateLanguage -> case parseLang rest translator of + Right newLang -> modify (\(AppState (p, r, pr, s, sp, pp, _)) -> AppState (p, r, pr, s, sp, pp, newLang)) >> loop world + Left err -> liftIO (printBig textSize err) >> promptLoop world + _ -> case cmd of + _ | cmd == translator commandQuit -> liftIO (printBig textSize (translator feedbackGoodbye) >> exitSuccess) + "?" -> liftIO (printBig textSize (helpText translator)) >> promptLoop world + _ | cmd == translator commandHelp -> liftIO (printBig textSize (helpText translator)) >> promptLoop world + _ -> case move (worldBounds world) cmd currentPos currentRot translator of + Nothing -> liftIO (printBig textSize (translator feedbackUnknownCommand ++ ": \"" ++ cmd ++ "\". " ++ translator feedbackHelpUnknownCommand)) >> promptLoop world + Just (p', r') -> modify (\(AppState (_, _, pr, s, sp, pp, lang)) -> AppState (p', r', pr, s, sp, pp, lang)) >> loop world
+ src/Terminal3D/Matrix.hs view
@@ -0,0 +1,90 @@+module Terminal3D.Matrix where + +import Terminal3D.Vector + +-- | A 4x4 Matrix. +data Mat4 = Mat4 Vec4 Vec4 Vec4 Vec4 deriving (Show, Eq) + +-- | Transpose a 4x4 matrix +transposeMat4 :: Mat4 -> Mat4 +transposeMat4 (Mat4 (Vec4 r1c1 r1c2 r1c3 r1c4) + (Vec4 r2c1 r2c2 r2c3 r2c4) + (Vec4 r3c1 r3c2 r3c3 r3c4) + (Vec4 r4c1 r4c2 r4c3 r4c4)) = + Mat4 + (Vec4 r1c1 r2c1 r3c1 r4c1) + (Vec4 r1c2 r2c2 r3c2 r4c2) + (Vec4 r1c3 r2c3 r3c3 r4c3) + (Vec4 r1c4 r2c4 r3c4 r4c4) + +instance Semigroup Mat4 where + (<>) (Mat4 r1 r2 r3 r4) m2 = + let m2T = transposeMat4 m2 + in Mat4 (multMatVec m2T r1) + (multMatVec m2T r2) + (multMatVec m2T r3) + (multMatVec m2T r4) + +instance Monoid Mat4 where + mempty = Mat4 + (Vec4 1 0 0 0) + (Vec4 0 1 0 0) + (Vec4 0 0 1 0) + (Vec4 0 0 0 1) + +-- | Multiply a 4x4 matrix by a column Vec4 +multMatVec :: Mat4 -> Vec4 -> Vec4 +multMatVec (Mat4 r1 r2 r3 r4) colV = + Vec4 (dot r1 colV) (dot r2 colV) (dot r3 colV) (dot r4 colV) + +-- | Perspective-divide: divide x, y, z by w +divW :: Vec4 -> Vec4 +divW (Vec4 x y z w) = Vec4 (x/w) (y/w) (z/w) w + +-- | Apply a rotation matrix to a Vec3 (homogeneous) +rotateWorld :: Mat4 -> Vec3 -> Vec3 +rotateWorld m (Vec3 a b c) = toVec3 (divW (multMatVec m (Vec4 a b c 1))) + +-- | Build a perspective matrix that respects the screen's aspect ratio +screenPerspectiveMatrix :: (Int, Int) -> Double -> Double -> Mat4 +screenPerspectiveMatrix (screenX, screenY) n f = + let ratio = fromIntegral screenY / fromIntegral screenX + (right, top) = if screenX > screenY then (1, ratio) else (1/ratio, 1) + in symmetricPerspectiveMatrix right n top f + +-- | Symmetric perspective matrix (see https://www.mauriciopoppe.com/notes/computer-graphics/viewing/projection-transform/ Eq. 12) +symmetricPerspectiveMatrix :: Double -> Double -> Double -> Double -> Mat4 +symmetricPerspectiveMatrix r n t f = Mat4 + (Vec4 (n/r) 0 0 0 ) + (Vec4 0 (n/t) 0 0 ) + (Vec4 0 0 ((f+n)/(n-f)) (2*f*n/(n-f))) + (Vec4 0 0 (-1) 0 ) + +-- | Rotation matrix around the X axis (pitch) +pitchMatrix :: Double -> Mat4 +pitchMatrix a = Mat4 + (Vec4 1 0 0 0) + (Vec4 0 (cos a) (-sin a) 0) + (Vec4 0 (sin a) (cos a) 0) + (Vec4 0 0 0 1) + +-- | Rotation matrix around the Y axis (yaw) +yawMatrix :: Double -> Mat4 +yawMatrix a = Mat4 + (Vec4 ( cos a) 0 ( sin a) 0) + (Vec4 0 1 0 0) + (Vec4 (-sin a) 0 ( cos a) 0) + (Vec4 0 0 0 1) + +-- | Rotation matrix around the Z axis (roll) +rollMatrix :: Double -> Mat4 +rollMatrix a = Mat4 + (Vec4 (cos a) (-sin a) 0 0) + (Vec4 (sin a) (cos a) 0 0) + (Vec4 0 0 1 0) + (Vec4 0 0 0 1) + +-- | Combined pitch/yaw/roll rotation matrix from a Vec3 of Euler angles +rotationMatrix :: Vec3 -> Mat4 +rotationMatrix (Vec3 pitch yaw roll) = + mconcat [pitchMatrix pitch, yawMatrix yaw, rollMatrix roll]
+ src/Terminal3D/Movement.hs view
@@ -0,0 +1,46 @@+module Terminal3D.Movement where +import Terminal3D.Vector +import Data.List (find) +import Terminal3D.Localization + +{-| A possible movement operation containning a position transform (rotation -> position -> output position) + , rotation transform, action character, and full name -} +data MoveOperation = MoveOperation (Vec3 -> Vec3 -> Vec3) (Vec3 -> Vec3) Char Local + +-- | A list of operations and how they transform the 3d spacial and rotational coordinates +moveOperations :: [MoveOperation] +moveOperations = + [ + MoveOperation (const id) id 'n' commandDoNothing, + MoveOperation (\(Vec3 _ yaw _) (Vec3 x y z) -> Vec3 (x - speed * sin yaw) y (z + speed * cos yaw)) id 'w' commandForward, + MoveOperation (\(Vec3 _ yaw _) (Vec3 x y z) -> Vec3 (x + speed * sin yaw) y (z - speed * cos yaw)) id 's' commandBackward, + MoveOperation (\(Vec3 _ yaw _) (Vec3 x y z) -> Vec3 (x - speed * cos yaw) y (z - speed * sin yaw)) id 'd' commandRight, + MoveOperation (\(Vec3 _ yaw _) (Vec3 x y z) -> Vec3 (x + speed * cos yaw) y (z + speed * sin yaw)) id 'a' commandLeft, + MoveOperation (const id) (\(Vec3 p y r) -> Vec3 p (y - yawInc) r) 'j' commandTurnLeft, + MoveOperation (const id) (\(Vec3 p y r) -> Vec3 p (y + yawInc) r) 'l' commandTurnRight, + MoveOperation (const id) (\(Vec3 p y r) -> Vec3 (p + pitchInc) y r) 'i' commandTurnUp, + MoveOperation (const id) (\(Vec3 p y r) -> Vec3 (p - pitchInc) y r) 'k' commandTurnDown + ] + where + speed = 5 + pitchInc = 0.2 + yawInc = 0.2 + +-- | Optional boundaries of a world the player cannot leave past as (minX, maxX, minZ, maxZ). +type Bounds = (Int, Int, Int, Int) + +-- | Push a position back inside the bounds. Makes it so the player can't leave the area +clampToBounds :: Maybe Bounds -> Vec3 -> Vec3 +clampToBounds Nothing pos = pos +clampToBounds (Just (minX, maxX, minZ, maxZ)) (Vec3 x y z) = + Vec3 (clamp minX maxX x) y (clamp minZ maxZ z) + where + clamp lo hi = max (fromIntegral lo) . min (fromIntegral hi) + +-- | Parse a movement command and return updated (position, rotation), or Nothing if invalid. +move :: Maybe Bounds -> String -> Vec3 -> Vec3 -> (Local -> String) -> Maybe (Vec3, Vec3) +move bounds cmd pos rot translator = + case find (\(MoveOperation _ _ c name) -> translator name == cmd || [c] == cmd) moveOperations of + Just (MoveOperation posT rotT _ _) -> Just (clampToBounds bounds (posT rot pos), rotT rot) + Nothing -> Nothing +
+ src/Terminal3D/Objects.hs view
@@ -0,0 +1,253 @@+module Terminal3D.Objects where + +import Terminal3D.Tri +import Terminal3D.Vector +import Terminal3D.Textures +import Terminal3D.Matrix + +-- | Build a textured quad (two triangles) from four corner vertices and a texture +texWallFormer :: Texture -> Vec3 -> Vec3 -> Vec3 -> Vec3 -> [Tri Vec3] +texWallFormer tex v0 v1 v2 v3 = + [ Tri v0 v1 v2 (Texture (TextureMapping tex (Vec2 0 0) (Vec2 1 0) (Vec2 1 1))) + , Tri v0 v2 v3 (Texture (TextureMapping tex (Vec2 0 0) (Vec2 1 1) (Vec2 0 1))) + ] + +-- | Build a textured quad (two triangles) from four corner vertices and a solid +solWallFormer :: RGB -> Vec3 -> Vec3 -> Vec3 -> Vec3 -> [Tri Vec3] +solWallFormer rgb v0 v1 v2 v3 = + [ Tri v0 v1 v2 (Solid rgb) + , Tri v0 v2 v3 (Solid rgb) + ] + +type WallFormer = Vec3 -> Vec3 -> Vec3 -> Vec3 -> [Tri Vec3] + +treeFormer :: WallFormer -> WallFormer -> [Tri Vec3] +treeFormer trunkFormer leafFormer = + trunkFormer -- Trunk + (Vec3 (-trunkW) (-trunkH) 0) + (Vec3 trunkW (-trunkH) 0) + (Vec3 trunkW 0 0) + (Vec3 (-trunkW) 0 0) + ++ trunkFormer + (Vec3 0 (-trunkH) (-trunkW)) + (Vec3 0 (-trunkH) trunkW) + (Vec3 0 0 trunkW) + (Vec3 0 0 (-trunkW)) + ++ leafFormer -- Left Leaf + (Vec3 0 leafH 0) (Vec3 (-leafW) 0 0) (Vec3 leafW 0 0) (Vec3 0 leafH 0) + ++ leafFormer -- Front Leaf + (Vec3 0 leafH 0) (Vec3 0 0 (-leafW)) (Vec3 0 0 leafW) (Vec3 0 leafH 0) + where + trunkH = 4 + trunkW = 2 + leafH = 14 + leafW = 8 + +-- | Makes island +islandFormer :: Double -> Double -> WallFormer -> WallFormer -> [Tri Vec3] +islandFormer radius height sideFormer baseFormer = + let angle i = (pi / 3) * fromIntegral i + basePt i = Vec3 (radius * cos (angle i)) 0 (radius * sin (angle i)) + apex = Vec3 0 (-height) 0 + baseCtr = Vec3 0 0 0 + sides = concat + [ fmap flipTri (sideFormer (basePt i) (basePt (i + 1)) apex apex) + | i <- [0 :: Int .. 5] + ] + base = concat + [ fmap flipTri (baseFormer baseCtr (basePt i) (basePt (i + 1)) baseCtr) + | i <- [0 :: Int .. 5] + ] + in sides ++ base + +-- | Builds a room from a Vec3 featuring one corner and another with the opposite corner +roomFormer :: Vec3 -> Vec3 -> WallFormer -> WallFormer -> [Tri Vec3] +roomFormer roomMin roomMax floorFormer wallFormer = + let + roomFloor = fmap flipTri (floorFormer + (comp3Reduce roomMin roomMin roomMin) + (comp3Reduce roomMax roomMin roomMin) + (comp3Reduce roomMax roomMin roomMax) + (comp3Reduce roomMin roomMin roomMax)) + wallFront = wallFormer + (comp3Reduce roomMin roomMin roomMax) + (comp3Reduce roomMax roomMin roomMax) + (comp3Reduce roomMax roomMax roomMax) + (comp3Reduce roomMin roomMax roomMax) + wallBack = wallFormer + (comp3Reduce roomMax roomMin roomMin) + (comp3Reduce roomMin roomMin roomMin) + (comp3Reduce roomMin roomMax roomMin) + (comp3Reduce roomMax roomMax roomMin) + wallLeft = wallFormer + (comp3Reduce roomMin roomMin roomMin) + (comp3Reduce roomMin roomMin roomMax) + (comp3Reduce roomMin roomMax roomMax) + (comp3Reduce roomMin roomMax roomMin) + wallRight = wallFormer + (comp3Reduce roomMax roomMin roomMax) + (comp3Reduce roomMax roomMin roomMin) + (comp3Reduce roomMax roomMax roomMin) + (comp3Reduce roomMax roomMax roomMax) + in concat [roomFloor, wallFront, wallBack, wallLeft, wallRight] + + +-- | Build a pair of linked portal quads with decorative borders +portalFormer :: WallFormer -> WallFormer -> (Vec3, Vec3) -> (Vec3, Vec3) -> Bool -> [Tri Vec3] +portalFormer texAFormer texBFormer (vA0, vA2) (vB0, vB2) flipPortal = + let vA1 = Vec3 (vF vA0) (vM vA2) (vL vA0) + vA3 = Vec3 (vF vA2) (vM vA0) (vL vA2) + vB1 = Vec3 (vF vB0) (vM vB2) (vL vB0) + vB3 = Vec3 (vF vB2) (vM vB0) (vL vB2) + rotSrc = triToBasisMat (vA0, vA1, vA2) + rotDst = triToBasisMat (if flipPortal then (vB0, vB2, vB1) else (vB0, vB1, vB2)) + portalRotMatrix = rotSrc <> transposeMat4 rotDst + in [ Tri vA0 vA1 vA2 (Portal vB0 vB1 vB2 portalRotMatrix) + , Tri vA0 vA2 vA3 (Portal vB0 vB2 vB3 portalRotMatrix) + , Tri vB0 vB1 vB2 (Portal vA0 vA1 vA2 portalRotMatrix) + , Tri vB0 vB2 vB3 (Portal vA0 vA2 vA3 portalRotMatrix) + ] + ++ borderFormer texAFormer (vA0, vA1, vA2, vA3) True + ++ borderFormer texBFormer (vB0, vB1, vB2, vB3) False + +-- | Build a slightly-scaled border quad around a portal face +borderFormer :: WallFormer -> (Vec3, Vec3, Vec3, Vec3) -> Bool -> [Tri Vec3] +borderFormer wallFormer (v0, v1, v2, v3) flipBool = + let normNotDirec = (v3 - v0) `cross` (v2 - v0) + direc = if flipBool then negate normNotDirec else normNotDirec + borderOffset = vMap (*0.01) (signum direc) + center = vMap (/2) (v0 + v2) + scalOp = (* 1.2) + b0 = vMap scalOp (v0 - center) + center + borderOffset + b1 = vMap scalOp (v1 - center) + center + borderOffset + b2 = vMap scalOp (v2 - center) + center + borderOffset + b3 = vMap scalOp (v3 - center) + center + borderOffset + in wallFormer b0 b1 b2 b3 + +-- | Build a textured unit cube centred at the origin (side length 20) +cubeFormer :: WallFormer -> [Tri Vec3] +cubeFormer sideFormer = + let p000 = Vec3 (-10) (-10) (-10); p001 = Vec3 (-10) (-10) 10 + p010 = Vec3 (-10) 10 (-10); p011 = Vec3 (-10) 10 10 + p100 = Vec3 10 (-10) (-10); p101 = Vec3 10 (-10) 10 + p110 = Vec3 10 10 (-10); p111 = Vec3 10 10 10 + in concat + [ sideFormer p001 p101 p111 p011 -- Front + , fmap flipTri (sideFormer p100 p000 p010 p110) -- Back + , sideFormer p000 p001 p011 p010 -- Left + , sideFormer p101 p100 p110 p111 -- Right + , sideFormer p011 p111 p110 p010 -- Top + , sideFormer p000 p100 p101 p001 -- Bottom + ] + +-- --------------------------------------------------------------------------- +-- New building blocks (used by the castle, fire, teapot and rainbow worlds) +-- --------------------------------------------------------------------------- + +-- | Build a box between two opposite corners (min corner first) by stretching the cube +boxFormer :: Vec3 -> Vec3 -> WallFormer -> [Tri Vec3] +boxFormer (Vec3 x0 y0 z0) (Vec3 x1 y1 z1) sideFormer = + (fmap . fmap) (\(Vec3 x y z) -> Vec3 (cx + x * sx) (cy + y * sy) (cz + z * sz)) (cubeFormer sideFormer) + where + cx = (x0 + x1) / 2 + cy = (y0 + y1) / 2 + cz = (z0 + z1) / 2 + sx = (x1 - x0) / 20 + sy = (y1 - y0) / 20 + sz = (z1 - z0) / 20 + +-- | Build a four sided pyramid from the centre of its base, half the base width and its height +pyramidFormer :: Vec3 -> Double -> Double -> WallFormer -> [Tri Vec3] +pyramidFormer (Vec3 cx cy cz) halfW height sideFormer = + let base = [ Vec3 (cx + halfW) cy (cz + halfW), Vec3 (cx - halfW) cy (cz + halfW) + , Vec3 (cx - halfW) cy (cz - halfW), Vec3 (cx + halfW) cy (cz - halfW) ] + apex = Vec3 cx (cy + height) cz + in concat [ sideFormer b' b apex apex | (b, b') <- zip base (drop 1 base ++ take 1 base) ] + +-- | Join two matching rings of points with a band of quads +bandFormer :: [Vec3] -> [Vec3] -> WallFormer -> [Tri Vec3] +bandFormer ringA ringB sideFormer = + let next ring = drop 1 ring ++ take 1 ring + in concat [ sideFormer a' a b b' + | ((a, a'), (b, b')) <- zip (zip ringA (next ringA)) (zip ringB (next ringB)) ] + +-- | Spin a list of (radius, height) points around the y axis to make a pot-like shape +latheFormer :: [(Double, Double)] -> WallFormer -> [Tri Vec3] +latheFormer profile sideFormer = + let ring (r, y) = [ Vec3 (r * cos a) y (r * sin a) | k <- [0 .. 7 :: Int], let a = (pi / 4) * fromIntegral k ] + rings = map ring profile + in concat (zipWith (\lo hi -> bandFormer lo hi sideFormer) rings (drop 1 rings)) + +-- | A castle: a keep, four corner towers with pointed roofs and walls between the towers +castleFormer :: WallFormer -> WallFormer -> [Tri Vec3] +castleFormer wallFormer roofFormer = + let tower (x, z) = boxFormer (Vec3 (x - 6) 0 (z - 6)) (Vec3 (x + 6) 30 (z + 6)) wallFormer + ++ pyramidFormer (Vec3 x 30 z) 7 14 roofFormer + keep = boxFormer (Vec3 (-15) 0 (-15)) (Vec3 15 40 15) wallFormer + ++ pyramidFormer (Vec3 0 40 0) 16 20 roofFormer + curtain = concat + [ boxFormer (Vec3 (-30) 0 (-31)) (Vec3 30 12 (-29)) wallFormer + , boxFormer (Vec3 (-30) 0 29) (Vec3 30 12 31) wallFormer + , boxFormer (Vec3 (-31) 0 (-30)) (Vec3 (-29) 12 30) wallFormer + , boxFormer (Vec3 29 0 (-30)) (Vec3 31 12 30) wallFormer + ] + in keep ++ curtain ++ concatMap tower [ (x, z) | x <- [-30, 30], z <- [-30, 30] ] + +-- | A campfire: crossed logs with red, orange and yellow flames +fireFormer :: WallFormer -> WallFormer -> WallFormer -> WallFormer -> [Tri Vec3] +fireFormer logFormer redFormer orangeFormer yellowFormer = + let logs = boxFormer (Vec3 (-12) 0 (-2)) (Vec3 12 4 2) logFormer + ++ boxFormer (Vec3 (-2) 0 (-12)) (Vec3 2 4 12) logFormer + flame (x, z, w, h, former) = pyramidFormer (Vec3 x 4 z) w h former + in logs ++ concatMap flame + [ (-6, 3, 5, 16, redFormer), (6, -3, 5, 18, redFormer), (3, 7, 4, 12, redFormer), (-4, -7, 4, 14, redFormer) + , (0, 0, 5, 26, orangeFormer), (-2, 2, 3, 20, orangeFormer), (2, -2, 3, 22, orangeFormer) + , (0, 0, 2.5, 34, yellowFormer) + ] + +-- | A teapot: round body with lid and knob, plus a spout and a handle in a second style +teapotFormer :: WallFormer -> WallFormer -> [Tri Vec3] +teapotFormer bodyFormer trimFormer = body ++ spout ++ handle + where + body = latheFormer + [ (0, 0), (7, 0), (11, 4), (12, 9), (10, 14), (7, 16) -- base and belly + , (7, 17), (4, 19), (2, 19), (2, 21), (0, 22) ] -- lid and knob + bodyFormer + spout = bandFormer + [Vec3 10 3 (-2), Vec3 10 3 2, Vec3 10 8 2, Vec3 10 8 (-2)] + [Vec3 19 13 (-1), Vec3 19 13 1, Vec3 19 16 1, Vec3 19 16 (-1)] + trimFormer + handle = boxFormer (Vec3 (-17) 11 (-1.5)) (Vec3 (-9) 13 1.5) trimFormer + ++ boxFormer (Vec3 (-17) 4 (-1.5)) (Vec3 (-15) 13 1.5) trimFormer + ++ boxFormer (Vec3 (-17) 3 (-1.5)) (Vec3 (-9) 5 1.5) trimFormer + +-- | One ring of the rainbow: a thick arched band between an inner and outer radius +ringFormer :: (Double, Double) -> WallFormer -> [Tri Vec3] +ringFormer (rIn, rOut) former = concat [ bandFormer s0 s1 former | (s0, s1) <- zip slices (drop 1 slices) ] + where + slices = map slice [0 .. 12 :: Int] + slice k = [point rIn (-2) k, point rOut (-2) k, point rOut 2 k, point rIn 2 k] + point r z k = Vec3 (r * cos (angle k)) (r * sin (angle k)) z + angle k = pi * fromIntegral k / 12 + +-- | A rainbow arch made of one ring per style given (outermost first) +rainbowFormer :: [WallFormer] -> [Tri Vec3] +rainbowFormer bandFormers = concat [ ringFormer (rOut - 3.6, rOut) former | (rOut, former) <- zip [59.6, 55.6 ..] bandFormers ] + +-- | Repeat a wall former over a grid of tiles (cols along the first edge, rows along the last) so a texture repeats instead of stretching +tiledFormer :: Int -> Int -> WallFormer -> WallFormer +tiledFormer cols rows former v0 v1 _ v3 = + concat [ former (at i j) (at (i + 1) j) (at (i + 1) (j + 1)) (at i (j + 1)) + | i <- [0 .. cols - 1], j <- [0 .. rows - 1] ] + where + at i j = v0 + vMap (* (fromIntegral i / fromIntegral cols)) (v1 - v0) + + vMap (* (fromIntegral j / fromIntegral rows)) (v3 - v0) + +-- | A winding river of lava made of flat slabs lying on the ground (y = 0), running from the back of the room to the front +lavaFormer :: WallFormer -> [Tri Vec3] +lavaFormer flowFormer = concatMap slab + [ (-48, -100, -32, -58), (-48, -58, 32, -42), (16, -42, 32, 10), (-60, 10, 32, 26), (-60, 26, -44, 100) ] + where + slab (x0, z0, x1, z1) = fmap flipTri (tiledFormer (tiles (x1 - x0)) (tiles (z1 - z0)) flowFormer + (Vec3 x0 0 z0) (Vec3 x1 0 z0) (Vec3 x1 0 z1) (Vec3 x0 0 z1)) + tiles len = max 1 (round (len / 16))
+ src/Terminal3D/TerminalGraphics.hs view
@@ -0,0 +1,167 @@+module Terminal3D.TerminalGraphics where++import Terminal3D.Tri+import Terminal3D.Vector+import Terminal3D.Textures+import Terminal3D.Matrix+import Control.Parallel.Strategies+import Control.Comonad+import qualified Data.ByteString.Builder as ByteBuilder+import qualified Data.ByteString.Lazy as LazyByteBuilder+import qualified Data.ByteString as StrictBS+import Terminal3D.Localization++displayProjection :: (Local -> String) -> Projection -> String+displayProjection translator Perspective = translator inputTypeProjection+displayProjection translator Affine = translator inputTypeAffine++-- | A 2D grid of values backed by a nested list+newtype Grid a = Grid { gData :: [[a]] }++instance Functor Grid where+ fmap f (Grid rows) = Grid ((fmap . fmap) f rows)++-- | 2D list index with edge clamping+gridAt :: Grid a -> Int -> Int -> a+gridAt (Grid rows) x y =+ let yOut = max 0 (min (length rows - 1) y)+ xOut = max 0 (min (length (rows !! yOut) - 1) x)+ in rows !! yOut !! xOut++-- | A Grid with a focused point for comonadic extension+data FGrid a = FGrid (Int, Int) (Grid a)++instance Functor FGrid where+ fmap f (FGrid focus (Grid rows)) = FGrid focus (Grid ((fmap . fmap) f rows))++instance Comonad FGrid where+ extract (FGrid (c, r) g) = gridAt g c r+ duplicate fg@(FGrid _ (Grid rows)) =+ let h = length rows+ w = maybe 0 length (lookup (0 :: Int) (zip [0..] rows))+ in FGrid (0, 0) (Grid [ [ FGrid (c, r) (unfocusGrid fg)+ | c <- [0 .. w - 1] ]+ | r <- [0 .. h - 1] ])+ extend f = fmap f . duplicate++-- | Removes a focus point from a focused grid and just returns the grid+unfocusGrid :: FGrid a -> Grid a+unfocusGrid (FGrid _ g) = g++-- | Wraps a grid with a default focus at the corner+focusGrid :: Grid a -> FGrid a+focusGrid = FGrid (0, 0)++-- | Gets a weighted average of a list of RGB colours.+blendRGB :: [(Double, RGB)] -> RGB+blendRGB [] = RGB 0 0 0+blendRGB ws = RGB (chanC red) (chanC green) (chanC blue)+ where+ total = sum (map fst ws)+ chanC f = round . max 0 $ sum [ w * fromIntegral (f c) | (w, c) <- ws ] / total++-- | Blends nearby grid cells using a weighted offset kernel+neighbourhood :: [(Int, Int, Double)] -> FGrid RGB -> RGB+neighbourhood offsets (FGrid (cx, cy) g) =+ blendRGB [ (w, gridAt g (cx+dc) (cy+dr)) | (dc, dr, w) <- offsets ]++class Default a where+ def :: a++instance Default AntiAliasing where+ def = aaBox 1++data AntiAliasing = AntiAliasing {+ aaName :: Local,+ aaSize :: Int,+ runAA :: [(Int, Int, Double)]+ }++dispalyAntiAliasing :: (Local -> String) -> AntiAliasing -> String+dispalyAntiAliasing translator = liftA2 (++) (translator . aaName) $ (": " ++) . show . aaSize++-- | Creates a uniform box filter anti-aliasing with an nxn kernel+aaBox :: Int -> AntiAliasing+aaBox n = AntiAliasing inputTypeBox n offsets+ where+ offsets+ | n <= 1 = [(0, 0, 1)]+ | even n = runAA (aaBox (n - 1))+ | otherwise = [ (dc, dr, 1) | dr <- [-r..r], dc <- [-r..r] ]+ r = n `div` 2++-- | Creates a gaussian weighted anti-aliasing with an nxn kernel+aaGaussian :: Int -> AntiAliasing+aaGaussian n = AntiAliasing inputTypeGaussian n offsets+ where+ offsets+ | n <= 1 = [(0, 0, 1)]+ | even n = runAA (aaGaussian (n - 1))+ | otherwise = [ (dc, dr, w dc dr) | dr <- [-r..r], dc <- [-r..r] ]+ r = n `div` 2+ sigma = fromIntegral n / 6+ w dc dr = exp (negate (fromIntegral (dc*dc + dr*dr)) / (2 * sigma * sigma))++aaMethods :: [Int -> AntiAliasing]+aaMethods = [aaBox, aaGaussian]++-- | Converts integer pixel offsets to normalised sub-pixel sample positions+toSubPixel :: [(Int, Int, Double)] -> [(Double, Double, Double)]+toSubPixel offsets = [ (fromIntegral dc / fromIntegral r, fromIntegral dr / fromIntegral r, w) | (dc, dr, w) <- offsets ]+ where r = maximum [ max (abs dc) (abs dr) | (dc, dr, _) <- offsets ] + 1++-- | Clear the terminal using ANSI escape codes+clearScreen :: IO ()+clearScreen = putStr (concat (replicate 50 "\n") ++ "\ESC[2J\ESC[H")++-- | Convert an RGB value to a true-colour ANSI SGR escape sequence+colorToANSITRUE :: RGB -> Bool -> String+colorToANSITRUE (RGB r g b) foreground =+ let mode = if foreground then (38 :: Integer) else 48+ in "\ESC[" ++ show mode ++ ";2;" ++ show r ++ ";" ++ show g ++ ";" ++ show b ++ "m"++-- | Convert pixel coordinates to normalised screen space (centred at 0.5)+toScreenRel :: (Double, Double) -> (Int, Int) -> Vec2+toScreenRel (x, y) (screenWidth, screenHeight) =+ Vec2 ((x / fromIntegral screenWidth) - 0.5)+ ((y / fromIntegral screenHeight) - 0.5)++-- Converts RGB containning a property with a 256 possible value for each color to an ANSI string for the color+rgbToANSI :: RGB -> String+rgbToANSI color = colorToANSITRUE color True ++ colorToANSITRUE color False ++ "▀\ESC[0m"++-- Convert pixel to builder instead of String+rgbToBuilder :: RGB -> ByteBuilder.Builder+rgbToBuilder (RGB r g b) = mconcat [+ ByteBuilder.string7 "\ESC[38;2;",+ ByteBuilder.word8Dec r,+ ByteBuilder.char7 ';',+ ByteBuilder.word8Dec g,+ ByteBuilder.char7 ';',+ ByteBuilder.word8Dec b,+ ByteBuilder.string7 "m\ESC[48;2;",+ ByteBuilder.word8Dec r,+ ByteBuilder.char7 ';',+ ByteBuilder.word8Dec g,+ ByteBuilder.char7 ';',+ ByteBuilder.word8Dec b,+ ByteBuilder.string7 "m",+ ByteBuilder.byteString (StrictBS.pack [0xe2, 0x96, 0x80]),+ ByteBuilder.string7 "\ESC[0m"+ ]++-- | Render a full frame to a 'String', processing rows in parallel+getScreen :: [Tri Vec4] -> (Int, Int) -> Projection -> [Tri Vec3] -> Mat4 -> AntiAliasing -> AntiAliasing -> LazyByteBuilder.ByteString+getScreen tris screenDimensions@(screenWidth, screenHeight) proj worldRegress rotRegress ssaa ppaa =+ let samples = toSubPixel (runAA ssaa)+ rawGrid :: Grid RGB+ rawGrid = Grid (map renderRow [0, 2 .. screenHeight - 1] `using` parListChunk 8 rdeepseq)++ renderRow :: Int -> [RGB]+ renderRow y =+ [ blendRGB [ (w, let Vec2 xRel yRel = toScreenRel (fromIntegral x + dx, fromIntegral y + dy) screenDimensions+ in getColorOfPixel (Vec2 xRel yRel) tris proj worldRegress 6 rotRegress)+ | (dx, dy, w) <- samples ]+ | x <- [0 .. screenWidth - 1] ]+ in ByteBuilder.toLazyByteString . foldMap (\row -> foldMap rgbToBuilder row <> ByteBuilder.char7 '\n')+ . gData . unfocusGrid $ extend (neighbourhood (runAA ppaa)) (focusGrid rawGrid)
+ src/Terminal3D/Textures.hs view
@@ -0,0 +1,63 @@+module Terminal3D.Textures where + +import qualified Data.ByteString as BS +import Data.Bits +import Data.Word +import Control.Monad +import Data.Array +import Control.DeepSeq + +type Texture = Array (Int, Int) RGB + +-- | RGB pixel type +data RGB = RGB { red :: Word8, green :: Word8, blue :: Word8 } deriving (Show, Eq) + +instance NFData RGB where + rnf (RGB r g b) = r `seq` g `seq` b `seq` () + +-- | Z-buffer ordering: when two pixels coincide, compare by channel values +instance Ord RGB where + compare (RGB r1 g1 b1) (RGB r2 g2 b2) = + compare r1 r2 <> compare g1 g2 <> compare b1 b2 + +-- | Map a numeric operation over all channels (useful for brightness scaling) +brightMap :: (Double -> Double) -> RGB -> RGB +brightMap f (RGB r g b) = RGB { red = fdoub r, green = fdoub g, blue = fdoub b } + where fdoub = round . max 0 . min 255 . f . fromIntegral + +-- | Safe little-endian 32-bit integer from 4 bytes +bytesToInt :: BS.ByteString -> Int +bytesToInt bs + | BS.length bs >= 4 = + fromIntegral (BS.index bs 0) + + (fromIntegral (BS.index bs 1) `shiftL` 8) + + (fromIntegral (BS.index bs 2) `shiftL` 16) + + (fromIntegral (BS.index bs 3) `shiftL` 24) + | otherwise = error "Not enough bytes to read Int" + +-- | Read a 24-bit uncompressed BMP file and return pixel rows (top-to-bottom) +readBMP :: FilePath -> IO Texture +readBMP path = do + content <- BS.readFile path + when (BS.take 2 content /= BS.pack [66,77]) + (error "Not a BMP file") + let bytesPerPixel = bytesToInt (BS.take 2 (BS.drop 28 content) `BS.append` BS.pack [0,0]) + when (bytesPerPixel /= 24) + (error ("Only 24-bit BMP files are supported. File has " ++ show bytesPerPixel ++ " bytes per pixel.")) + let imagePixelWidth = bytesToInt (BS.take 4 (BS.drop 18 content)) + imagePixelHeight = bytesToInt (BS.take 4 (BS.drop 22 content)) + offset = bytesToInt (BS.take 4 (BS.drop 10 content)) + rowByteCount = ((3*imagePixelWidth + 3) `div` 4) * 4 + pixelBytes = BS.drop offset content + getRow y = + let rowStart = (imagePixelHeight-1-y)*rowByteCount + rowBytes = BS.unpack (BS.take (3*imagePixelWidth) (BS.drop rowStart pixelBytes)) + parseRow (b:g:r:rest) = RGB { red = r, green = g, blue = b } : parseRow rest + parseRow [] = [] + parseRow _ = error "Incomplete pixel data" + in parseRow rowBytes + rows = [ getRow y | y <- [0..imagePixelHeight-1] ] + return $ listArray ((0,0), (imagePixelHeight-1, imagePixelWidth-1)) (concat rows) + +-- | UV texture mapping: a texture grid with three UV corner coordinates +data TextureMapping a = TextureMapping Texture a a a deriving Show
+ src/Terminal3D/Tri.hs view
@@ -0,0 +1,222 @@+module Terminal3D.Tri where + +import Terminal3D.Vector +import Terminal3D.Matrix +import Terminal3D.Textures +import Data.Word +import Data.Array + +-- | Projection mode for texture mapping +data Projection = Affine | Perspective + +-- | Build a change-of-basis matrix from three triangle vertices +triToBasisMat :: (Vec3, Vec3, Vec3) -> Mat4 +triToBasisMat (a, b, c) = + let right = signum (b - a) + normal = signum ((b - a) `cross` (c - a)) + up = normal `cross` right + in case map (`toVec4` 0) [right, up, normal] of + [r, u, n] -> Mat4 r u n (Vec4 0 0 0 1) + _ -> error "Impossible" + +{-| A tiny positive value used to keep geometry strictly in front of the camera, + avoiding division-by-zero in perspective projection. -} +epsilon :: Double +epsilon = 0.2 + +-- | How a triangle's surface is coloured +data ColorMapping + = Solid RGB + | Texture (TextureMapping Vec2) + | Portal Vec3 Vec3 Vec3 Mat4 + deriving Show + +{-| A triangle made of three vertices of type @a@ plus a colour mapping. + Texture UV coordinates correspond to vertices in declaration order. -} +data Tri a = Tri a a a ColorMapping deriving Show + +-- | Surface normal of a world-space triangle (not normalised) +getNorm :: Tri Vec3 -> Vec3 +getNorm (Tri v1 v2 v3 _) = (v2 - v1) `cross` (v3 - v1) + +-- | Reverse a triangle's winding order (flips its normal) +flipTri :: Tri a -> Tri a +flipTri (Tri vA vB vC (Texture (TextureMapping tex uvA uvB uvC))) = + Tri vA vC vB (Texture (TextureMapping tex uvA uvC uvB)) +flipTri (Tri vA vB vC (Solid col)) = + Tri vA vC vB (Solid col) +flipTri (Tri vA vB vC (Portal v2A v2B v2C rotTrans)) = + Tri vA vC vB (Portal v2A v2B v2C rotTrans) + +instance Functor Tri where + fmap f (Tri a b c texMap) = Tri (f a) (f b) (f c) texMap + +-- | Extract the three vertices of a triangle +triToVec :: Tri a -> (a, a, a) +triToVec (Tri a b c _) = (a, b, c) + +-- | Compute barycentric coordinates and depth for a point inside a projected triangle +barycentricDepth :: Vec2 -> Tri Vec4 -> Maybe Vec4 +barycentricDepth p (Tri vecA vecB vecC _) = + let vecAtoB = toVec2 (vecB - vecA) + vecAtoC = toVec2 (vecC - vecA) + vecAtoP = p - toVec2 vecA + dot00 = vecAtoB `dot` vecAtoB + dot01 = vecAtoB `dot` vecAtoC + dot02 = vecAtoB `dot` vecAtoP + dot11 = vecAtoC `dot` vecAtoC + dot12 = vecAtoC `dot` vecAtoP + denom = dot00 * dot11 - dot01 * dot01 + in if denom < 1e-8 then Nothing + else + let v = (dot11 * dot02 - dot01 * dot12) / denom + w = (dot00 * dot12 - dot01 * dot02) / denom + u = 1 - v - w + zVec = component3 vZ (vecA, vecB, vecC) + z = Vec3 u v w `dot` zVec + in Just (Vec4 u v w z) + +-- | True when barycentric coordinates are inside (or on the edge of) the triangle +insideTriangle :: Vec3 -> Bool +insideTriangle (Vec3 u v w) = + let eps = 1e-9 in u >= -eps && v >= -eps && w >= -eps + +-- | Nearest-neighbour texture sample given a UV in [0,1]² +sampleTexture :: Texture -> Vec2 -> RGB +sampleTexture tex uvCoord = + let ((_, _), (maxY, maxX)) = bounds tex + pixelX = min maxX (max 0 (round (vF sloper))) + pixelY = min maxY (max 0 (round (vL sloper))) + sloper = uvCoord * Vec2 (fromIntegral maxX) (fromIntegral maxY) + in tex ! (pixelY, pixelX) + +-- | Interpolate UV coordinates using barycentric weights (affine or perspective-correct) +interpolateUV :: Vec3 -> ColorMapping -> Vec3 -> Projection -> Vec2 +interpolateUV _ (Solid _) _ _ = Vec2 0 0 +interpolateUV _ (Portal {}) _ _ = Vec2 0 0 +interpolateUV bary (Texture (TextureMapping _ uvA uvB uvC)) _ Affine = + let xVec = component3 vF (uvA, uvB, uvC) + yVec = component3 vL (uvA, uvB, uvC) + in Vec2 (bary `dot` xVec) (bary `dot` yVec) +interpolateUV bary (Texture (TextureMapping _ uvA uvB uvC)) w' Perspective = + Vec2 (i vF) (i vL) + where + a' = vMap (/ vF w') uvA + b' = vMap (/ vM w') uvB + c' = vMap (/ vL w') uvC + invW = bary `dot` vMap recip w' + i f = bary `dot` component3 f (a', b', c') / invW + +-- | Return the RGB colour and depth of the nearest hit on a triangle at pixel @p@ +pointInsideTriColor + :: Vec2 -> Tri Vec4 -> Projection + -> [Tri Vec3] -> Word8 -> Mat4 + -> Maybe (RGB, Double) +pointInsideTriColor p tri@(Tri _ _ _ colorMapping) proj worldRegress regressCount rotRegress = do + barycentricCoords <- barycentricDepth p tri + if not (insideTriangle (toVec3 barycentricCoords) && vL barycentricCoords > epsilon) + then Nothing + else + let rgb = case colorMapping of + Portal vAOut vBOut vCOut portalRotMatrix -> + let newRot = portalRotMatrix <> rotRegress + mappedPoint = weight3 (vAOut, vBOut, vCOut) (toVec3 barycentricCoords) + ntcTris = posRotToNtcTris worldRegress (mappedPoint, newRot) + in getColorOfPixel p ntcTris proj worldRegress (regressCount-1) newRot + Solid c -> c + Texture (TextureMapping texturePixels _ _ _) -> + let w' = component3 vL (triToVec tri) + interpUv = interpolateUV (toVec3 barycentricCoords) colorMapping w' proj + in sampleTexture texturePixels interpUv + in Just (rgb, vL barycentricCoords) + +-- | Project a list of world-space triangles through a perspective matrix +get2DTris :: Vector spVec => Mat4 -> [Tri spVec] -> [Tri Vec4] +get2DTris perspectiveMat = map (\(Tri a b c color) -> + Tri (multMatVec perspectiveMat (toVec4 a 1)) + (multMatVec perspectiveMat (toVec4 b 1)) + (multMatVec perspectiveMat (toVec4 c 1)) + color) + +-- | Clip a triangle against the near plane (generic over space+UV vertex types) +clipTriGeneric + :: (Vector spcVec, Vector mapVec) + => ((spcVec, spcVec, spcVec), (mapVec, mapVec, mapVec)) + -> [((spcVec, spcVec, spcVec), (mapVec, mapVec, mapVec))] +clipTriGeneric ((vA, vB, vC), (v2A, v2B, v2C)) = + let groupedVerts = [(vA,v2A), (vB,v2B), (vC,v2C)] + frontVerts = filter inFront groupedVerts + backVerts = filter (not . inFront) groupedVerts + in case (frontVerts, backVerts) of + ([(fA,fB)], [b1,b2]) -> + let (i1A,i1B) = lerpVertGroupping (fA,fB) b1 + (i2A,i2B) = lerpVertGroupping (fA,fB) b2 + in [((fA,i1A,i2A),(fB,i1B,i2B))] + ([(f1A,f1B),(f2A,f2B)], [b]) -> + let (i1A,i1B) = lerpVertGroupping (f1A,f1B) b + (i2A,i2B) = lerpVertGroupping (f2A,f2B) b + in [((f1A,f2A,i2A),(f1B,f2B,i2B)), + ((f1A,i2A,i1A),(f1B,i2B,i1B))] + ([(f1A,f1B),(f2A,f2B),(f3A,f3B)], _) -> + [((f1A,f2A,f3A),(f1B,f2B,f3B))] + _ -> [] + where + inFront (vec, _) = vZ vec > epsilon + +-- | Clip a single triangle against the near plane +clipTri :: Tri Vec3 -> [Tri Vec3] +clipTri (Tri vA vB vC (Solid col)) = + map (\((vA', vB', vC'), _) -> Tri vA' vB' vC' (Solid col)) + (clipTriGeneric ((vA,vB,vC),(Vec2 0 0,Vec2 0 0,Vec2 0 0))) +clipTri (Tri vA vB vC (Texture (TextureMapping tex v2A v2B v2C))) = + map (\((vA', vB', vC'), (v2A', v2B', v2C')) -> + Tri vA' vB' vC' (Texture (TextureMapping tex v2A' v2B' v2C'))) + (clipTriGeneric ((vA,vB,vC),(v2A,v2B,v2C))) +clipTri (Tri vA vB vC (Portal v2A v2B v2C rotMat)) = + map (\((vA', vB', vC'), (v2A', v2B', v2C')) -> + Tri vA' vB' vC' (Portal v2A' v2B' v2C' rotMat)) + (clipTriGeneric ((vA,vB,vC),(v2A,v2B,v2C))) + +-- | Linearly interpolate between a front and back vertex at the near plane +lerpVertGroupping + :: (Vector spVec, Vector mapVec) + => (spVec, mapVec) -> (spVec, mapVec) -> (spVec, mapVec) +lerpVertGroupping (spVecFront, uvVecFront) (spVecBack, uvVecBack) = + let t = if vZ (spVecFront - spVecBack) == 2*epsilon + then 0.5 + else (vZ spVecFront - epsilon) / (vZ spVecFront - vZ spVecBack) + in ( spVecFront + vMap (t*) (spVecBack - spVecFront) + , uvVecFront + vMap (t*) (uvVecBack - uvVecFront) ) + +-- | Transform world triangles into normalised clip-space triangles for a given camera +posRotToNtcTris :: [Tri Vec3] -> (Vec3, Mat4) -> [Tri Vec4] +posRotToNtcTris world (pos, rotMat) = + let screenMat = symmetricPerspectiveMatrix 1 0.4 1 200 + movedTris = (fmap . fmap) (\v -> v - pos) world + viewTris = (fmap . fmap) (rotateWorld rotMat) movedTris + clippedViewTris = concatMap clipTri viewTris + screenTris = get2DTris screenMat clippedViewTris + ntcTris = (fmap . fmap) divW screenTris + in ntcTris + +-- | Check if a point is within a triangle's 2D bounding box (fast pre-rejection) +inTriAABB :: Vec2 -> Tri Vec4 -> Bool +inTriAABB (Vec2 px py) (Tri a b c _) = + let + axs = map (vF . toVec2) [a, b, c] + ays = map (vL . toVec2) [a, b, c] + in px >= minimum axs && px <= maximum axs && py >= minimum ays && py <= maximum ays + +-- | Find the RGB colour of the nearest triangle covering pixel @p@ +getColorOfPixel :: Vec2 -> [Tri Vec4] -> Projection -> [Tri Vec3] -> Word8 -> Mat4 -> RGB +getColorOfPixel _ _ _ _ 0 _ = RGB { red = 160, green = 32, blue = 240 } +getColorOfPixel p tris proj worldRegress regressCount rotRegress = + let candidates = [ + (d, rgb) + | tri <- tris, + inTriAABB p tri, + Just (rgb, d) <- [pointInsideTriColor p tri proj worldRegress regressCount rotRegress] + ] + in case candidates of + [] -> RGB { red = 0, green = 0, blue = 0 } + _ -> snd (maximum candidates)
+ src/Terminal3D/Vector.hs view
@@ -0,0 +1,104 @@+module Terminal3D.Vector where++-- | A Vector containing 2 components+data Vec2 = Vec2 {-# UNPACK #-} !Double {-# UNPACK #-} !Double deriving (Eq, Show)++-- | A Vector containing 3 components+data Vec3 = Vec3 {-# UNPACK #-} !Double {-# UNPACK #-} !Double {-# UNPACK #-} !Double deriving (Eq, Show)++-- | A Vector containing 4 components+data Vec4 = Vec4 {-# UNPACK #-} !Double {-# UNPACK #-} !Double {-# UNPACK #-} !Double {-# UNPACK #-} !Double deriving (Eq, Show)++-- Does Z Buffering to get the nearest Vector+instance Ord Vec3 where+ compare (Vec3 _ _ z1) (Vec3 _ _ z2) = compare z1 z2++-- | Vector Cross Product. Creates a new vector perpendicular to the other 2 vectors.+cross :: Vec3 -> Vec3 -> Vec3+cross (Vec3 x1 y1 z1) (Vec3 x2 y2 z2) = Vec3 (y1*z2-z1*y2) (z1*x2-x1*z2) (x1*y2-y1*x2)++instance Num Vec2 where+ (+) (Vec2 x1 y1) (Vec2 x2 y2) = Vec2 (x1+x2) (y1+y2)+ (*) (Vec2 x1 y1) (Vec2 x2 y2) = Vec2 (x1*x2) (y1*y2)+ abs = (`vMap` 1) . (*) . magnitude+ signum v = let mag = magnitude v in if mag == 0 then 0 else vMap (/mag) v+ fromInteger = (\n -> Vec2 n n) . fromIntegral+ negate = vMap (*(-1))++instance Num Vec3 where+ (+) (Vec3 x1 y1 z1) (Vec3 x2 y2 z2) = Vec3 (x1+x2) (y1+y2) (z1+z2)+ (*) (Vec3 x1 y1 z1) (Vec3 x2 y2 z2) = Vec3 (x1*x2) (y1*y2) (z1*z2)+ abs = (`vMap` 1) . (*) . magnitude+ signum v = let mag = magnitude v in if mag == 0 then 0 else vMap (/mag) v+ fromInteger = (\n -> Vec3 n n n) . fromIntegral+ negate = vMap (*(-1))++instance Num Vec4 where+ (+) (Vec4 x1 y1 z1 w1) (Vec4 x2 y2 z2 w2) = Vec4 (x1+x2) (y1+y2) (z1+z2) (w1+w2)+ (*) (Vec4 x1 y1 z1 w1) (Vec4 x2 y2 z2 w2) = Vec4 (x1*x2) (y1*y2) (z1*z2) (w1*w2)+ abs = (`vMap` 1) . (*) . magnitude+ signum v = let mag = magnitude v in if mag == 0 then 0 else vMap (/mag) v+ fromInteger = (\n -> Vec4 n n n n) . fromIntegral+ negate = vMap (*(-1))++-- | A vector contains a series of doubles+class Num vec => Vector vec where+ magnitude :: vec -> Double+ vMap :: (Double -> Double) -> vec -> vec+ dot :: vec -> vec -> Double+ toVec2 :: vec -> Vec2+ toVec3 :: vec -> Vec3+ toVec4 :: vec -> Double -> Vec4+ vF :: vec -> Double+ vL :: vec -> Double+ vZ :: vec -> Double++instance Vector Vec2 where+ magnitude (Vec2 x y) = sqrt (x*x + y*y)+ vMap f (Vec2 x y) = Vec2 (f x) (f y)+ dot (Vec2 x1 y1) (Vec2 x2 y2) = x1*x2 + y1*y2+ toVec2 = id+ toVec3 (Vec2 x y) = Vec3 x y 0+ toVec4 (Vec2 x y) = Vec4 x y 0+ vF (Vec2 x _) = x+ vL (Vec2 _ y) = y+ vZ (Vec2 _ _) = 0++instance Vector Vec3 where+ magnitude (Vec3 x y z) = sqrt (x*x + y*y + z*z)+ vMap f (Vec3 x y z) = Vec3 (f x) (f y) (f z)+ dot (Vec3 x1 y1 z1) (Vec3 x2 y2 z2) = x1*x2 + y1*y2 + z1*z2+ toVec2 (Vec3 x y _) = Vec2 x y+ toVec3 = id+ toVec4 (Vec3 x y z) = Vec4 x y z+ vF (Vec3 x _ _) = x+ vL (Vec3 _ _ z) = z+ vZ (Vec3 _ _ z) = z++-- | Get the Y component of a Vec3+vM :: Vec3 -> Double+vM (Vec3 _ y _) = y++instance Vector Vec4 where+ magnitude (Vec4 x y z w) = sqrt (x*x + y*y + z*z + w*w)+ vMap f (Vec4 x y z w) = Vec4 (f x) (f y) (f z) (f w)+ dot (Vec4 x1 y1 z1 w1) (Vec4 x2 y2 z2 w2) = x1*x2 + y1*y2 + z1*z2 + w1*w2+ toVec2 (Vec4 x y _ _) = Vec2 x y+ toVec3 (Vec4 x y z _) = Vec3 x y z+ toVec4 v _ = v+ vF (Vec4 x _ _ _) = x+ vL (Vec4 _ _ _ w) = w+ vZ (Vec4 _ _ z _) = z++-- | Extract one component from each of three values into a Vec3+component3 :: (a -> Double) -> (a, a, a) -> Vec3+component3 f (a, b, c) = Vec3 (f a) (f b) (f c)++-- | Build a Vec3 by taking X from first, Y from second, Z from third+comp3Reduce :: Vec3 -> Vec3 -> Vec3 -> Vec3+comp3Reduce a b c = Vec3 (vF a) (vM b) (vL c)++-- | Weighted sum of three Vec3s using barycentric weights+weight3 :: (Vec3, Vec3, Vec3) -> Vec3 -> Vec3+weight3 (vA, vB, vC) weights =+ vMap (* vF weights) vA + vMap (* vM weights) vB + vMap (* vZ weights) vC
+ terminal-3d-graphics.cabal view
@@ -0,0 +1,74 @@+cabal-version: 3.0 +name: terminal-3d-graphics +version: 0.2.0.0 +synopsis: A terminal 3D rasteriser with textures, portals, and baked lighting +description: + Simple multi-module Haskell terminal 3D engine. + Can be used as a library or compiled to a demo executable. +license: Unlicense +license-file: LICENSE +author: Larz Piechocki +maintainer: LarzPiechocki@gmail.com +homepage: https://github.com/LarzP123/terminal-3d-graphics +bug-reports: https://github.com/LarzP123/terminal-3d-graphics/issues +build-type: Simple +category: Graphics +extra-doc-files: README.md +extra-source-files: + textures/*.bmp + +source-repository head + type: git + location: https://github.com/LarzP123/terminal-3d-graphics + +-- ----------------------------------------------------------------------- +-- Common settings shared by library and executable +-- ----------------------------------------------------------------------- +common shared + default-language: Haskell2010 + build-depends: + array >= 0.5.7 && < 0.6, + base >= 4.20.0 && < 4.21, + bytestring >= 0.12.1 && < 0.13, + deepseq >= 1.5.0 && < 1.6, + comonad >= 5.0.10 && < 5.1, + transformers >= 0.6.1 && < 0.7, + parallel >= 3.3.0 && < 3.4, + process >= 1.6.19 && < 1.7, + ghc-options: + -Wall + -funbox-strict-fields + -fspecialise-aggressively + -optc-O3 + +-- ----------------------------------------------------------------------- +-- Library: import Terminal3D to use the engine in your own project +-- ----------------------------------------------------------------------- +library + import: shared + hs-source-dirs: src + exposed-modules: + Terminal3D + other-modules: + Terminal3D.Vector + Terminal3D.Matrix + Terminal3D.Textures + Terminal3D.Tri + Terminal3D.Lighting + Terminal3D.TerminalGraphics + Terminal3D.Objects + Terminal3D.BigText + Terminal3D.Movement + Terminal3D.Loop + Terminal3D.Localization + +-- ----------------------------------------------------------------------- +-- Executable: demo scene (room + cube + portals) +-- Run with: cabal run t3d +-- ----------------------------------------------------------------------- +executable t3d + import: shared + main-is: Main.hs + hs-source-dirs: app + ghc-options: -threaded -rtsopts + build-depends: terminal-3d-graphics:terminal-3d-graphics
+ textures/cube.bmp view
binary file changed (absent → 587466 bytes)
+ textures/floor.bmp view
binary file changed (absent → 786486 bytes)
+ textures/grass.bmp view
binary file changed (absent → 786486 bytes)
+ textures/lava.bmp view
binary file changed (absent → 1920054 bytes)
+ textures/leaf.bmp view
binary file changed (absent → 786486 bytes)
+ textures/portalBlue.bmp view
binary file changed (absent → 1702510 bytes)
+ textures/portalOrange.bmp view
binary file changed (absent → 1702510 bytes)
+ textures/rock.bmp view
binary file changed (absent → 786486 bytes)
+ textures/sky.bmp view
binary file changed (absent → 786486 bytes)
+ textures/trunk.bmp view
binary file changed (absent → 786486 bytes)
+ textures/wall.bmp view
binary file changed (absent → 786486 bytes)
+ textures/wallpaper.bmp view
binary file changed (absent → 587466 bytes)
+ textures/woodFloor.bmp view
binary file changed (absent → 580854 bytes)