{-# OPTIONS_GHC -F -pgmF htfpp #-} {-# OPTIONS_HADDOCK prune #-} {-| Module : Liquorice.Render Description : High-level functions for rendering Liquorice programs to PWAD files. Copyright : © Jonathan Dowland, 2020 License : GPL-3 Maintainer : jon+hackage@dow.land Stability : experimental Portability : POSIX This module exposes a high-level function `buildWad` that can be used to evaluate a Liquorice program, convert the resulting Context into Doom data structures and write out a Doom-format PWAD file. -} module Liquorice.Render ( buildWad , htf_thisModulesTests ) where import qualified Data.ByteString.Lazy as L import Test.Framework import Data.List (elemIndex) import Data.Function ((&)) import Liquorice import Liquorice.Pure import Liquorice.Line import Liquorice.Wad -- utility stuff ------------------------------------------------------------- addUnique :: Eq a => [a] -> a -> (Int,[a]) addUnique vs v = case elemIndex v vs of Nothing -> (length vs, vs++[v]) Just l -> (l, vs) prop_AddUniqueWorks :: [Int] -> Int -> Bool prop_AddUniqueWorks vs v = let (index,vs2) = addUnique vs v in v == vs2 !! index -- converting Liquorice structures into WAD structures --------------------------- convertWadL :: Context -> WadMap convertWadL c = let baseMap = WadMap (mapName c) (things c) [] [] [] [] in convertWadL' (sectors c) 0 baseMap where convertWadL' :: [Sector] -> Int -> WadMap -> WadMap convertWadL' [] _ m = m convertWadL' (s:ss) n m = let newS = s { sectorLines = [] } -- a hack m2 = convertLines (sectorLines s) n m m3 = m2 { mapSectors = mapSectors m2 ++ [newS] } in convertWadL' ss (n+1) m3 where convertLines :: [Line] -> Int -> WadMap -> WadMap convertLines [] _ m = m convertLines (l:ls) n m = convertLines ls n (line2Def l n m) -- XXX: detect existing line (backwards possibly); if present modify to 2 sided -- (means generating two new sidedefs) partitionLines :: Int -> Int -> WadMap -> [[Linedef]] partitionLines vfrom vto m = let existingLines = mapLinedefs m pred = \l -> (ldFrom l, ldTo l) `elem` [(vfrom,vto), (vto,vfrom)] before = takeWhile (not . pred) existingLines after = drop (length before) existingLines in [before,after] -- output if there's a match: [[all linedefs before], [match, all after]] -- output if there isn't: [[all linedefs], []] -- (need to avoid tail in "after" for the [] case) line2Def :: Line -> Int -> WadMap -> WadMap line2Def l secno m = let (vfrom, vs1) = addUnique (mapVertexes m) (from l) (vto, vs2) = addUnique vs1 (to l) [before,after] = partitionLines vfrom vto m in case after of -- old case, no overlap, single-sided [] -> let sidedef = Sidedef (lineXoff l) (lineYoff l) (lineTop l) (lineBot l) (lineMid l) secno (sno,sd2) = addUnique (mapSidedefs m) sidedef newline = Linedef vfrom vto 1 (lineType l) (lineTag l) sno (-1) newlines = mapLinedefs m ++ [newline] in m { mapVertexes = vs2, mapSidedefs = sd2, mapLinedefs = newlines } -- new case, 2-sided, replace existing line definition (oldline:ls) -> let oldside = (mapSidedefs m) !! (ldFront oldline) (so1,sd1) = addUnique (mapSidedefs m) oldside { sdMid = "-" } (so2,sd2) = addUnique sd1 (Sidedef (lineXoff l) (lineYoff l) (lineTop l) (lineBot l) "-" secno) newline = oldline { ldFlags = 4, ldFront = so1, ldBack = so2 } newlines = before ++ newline:ls in m { mapVertexes = vs2, mapSidedefs = sd2, mapLinedefs = newlines } -- | Convert the geometry described by the supplied Context into Doom-format -- structures and write them out as a PWAD file to the supplied FilePath. buildWad outfile wadcsrc = L.writeFile outfile $ (dumpWad . mapWad2Wad . convertWadL) wadcsrc -- tests --------------------------------------------------------------------- -- test 1: single triangular sector, unique texture per line wad1 = WadMap { mapLabel = "MAP01" , mapThings = [Thing (32, 64) 90 1 7] , mapLinedefs = [ Linedef 0 1 1 0 0 0 (-1) , Linedef 1 2 1 0 0 1 (-1) , Linedef 2 0 1 0 0 2 (-1) ] , mapSidedefs = [ Sidedef 0 0 "STARTAN3" "STARTAN3" "ZZWOLF1" 0 , Sidedef 0 0 "STARTAN3" "STARTAN3" "ZZWOLF2" 0 , Sidedef 0 0 "STARTAN3" "STARTAN3" "ZZWOLF3" 0 ] , mapVertexes = [(0, 0), (0, 128), (128, 128)] , mapSectors = [Sector 0 128 "FLAT23" "F_SKY1" 160 0 0 [] ] } example1 = start & mid "ZZWOLF1" & draw 128 0 & mid "ZZWOLF2" & draw 0 128 & turnaround & mid "ZZWOLF3" & draw 128 128 & rightsector 0 128 160 & turnaround & step 64 32 & thing test_equiv1 = assertEqual (convertWadL example1) wad1 -- test 2: two (disconnected) sectors example3 = start & box 128 128 0 128 160 & step 64 64 & thing & step 128 (-64) & box 128 128 0 128 160 wad3 = WadMap { mapLabel = "MAP01" , mapThings = [Thing (64, 64) 90 1 0] , mapLinedefs = [ Linedef 0 1 1 0 0 0 (-1) , Linedef 2 0 1 0 0 0 (-1) , Linedef 3 2 1 0 0 0 (-1) , Linedef 1 3 1 0 0 0 (-1) , Linedef 4 5 1 0 0 1 (-1) , Linedef 6 4 1 0 0 1 (-1) , Linedef 7 6 1 0 0 1 (-1) , Linedef 5 7 1 0 0 1 (-1) ] , mapSidedefs = [ Sidedef 0 0 "STARTAN3" "STARTAN3" "STARTAN3" 0 , Sidedef 0 0 "STARTAN3" "STARTAN3" "STARTAN3" 1 ] , mapVertexes = [(128, 192), (0, 192), (128, 320), (0, 320), (128, 0), (0, 0), (128, 128), (0, 128)] , mapSectors = [ Sector 0 128 "FLAT23" "F_SKY1" 160 0 0 [] , Sector 0 128 "FLAT23" "F_SKY1" 160 0 0 [] ] } --test_equiv3 = assertEqual (convertWadL example3) wad3 -- test 3: two adjacent sectors (2s line) (based on example4) example4 = start & box 128 128 0 128 160 & pushpop (\c -> c & step 64 64 & thing) & step 128 0 & box 128 128 0 128 160 wad4 = WadMap { mapLabel = "MAP01" , mapThings = [Thing (64, 64) 90 1 7] , mapLinedefs = [ Linedef 0 1 1 0 0 0 (-1) , Linedef 1 2 1 0 0 0 (-1) , Linedef 2 3 1 0 0 0 (-1) , Linedef 3 0 4 0 0 2 3 , Linedef 4 0 1 0 0 1 (-1) , Linedef 3 5 1 0 0 1 (-1) , Linedef 5 4 1 0 0 1 (-1) ] , mapSidedefs = [ Sidedef 0 0 "STARTAN3" "STARTAN3" "STARTAN3" 0 , Sidedef 0 0 "STARTAN3" "STARTAN3" "STARTAN3" 1 , Sidedef 0 0 "STARTAN3" "STARTAN3" "-" 0 , Sidedef 0 0 "STARTAN3" "STARTAN3" "-" 1 ] , mapVertexes = [(0,128),(0,256),(128,256),(128,128),(0,0),(128,0)] , mapSectors = [ Sector 0 128 "FLAT23" "F_SKY1" 160 0 0 [] , Sector 0 128 "FLAT23" "F_SKY1" 160 0 0 [] ] } test_equiv4 = assertEqual (convertWadL example4) wad4 main = htfMain htf_thisModulesTests