module Game.Waddle.ExportJS
(exportJS) where
import Game.Waddle.Types
import System.IO
import Data.List
import Text.Printf
import Data.Bits
import Data.Word
import Data.CaseInsensitive(CI)
import Data.Map(Map)
import qualified Data.Map as Map
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
exportJS :: Wad -> FilePath -> IO ()
exportJS Wad{..} dir = do
printf "levels: %d\n" (Map.size wadLevels)
forM_ (Map.elems wadLevels) $ \ Level{..} -> do
printf "Level %s:\n" (BS8.unpack levelName)
printf " vertices: %d\n" (length levelVertices)
printf " sideDefs: %d\n" (length levelSideDefs)
printf " lineDefs: %d\n" (length levelLineDefs)
printf " sectors: %d\n" (length levelSectors)
printf " reject: %d\n" (maybe 0 (BS.length . rejectBytes) levelReject)
printf " blockmap: %d\n"
(case levelBlockmap of
Just Blockmap{..} -> (blockmapColumns * blockmapRows)
Nothing -> 0)
printf " things: %d\n" (length levelThings)
printf "flats: %d\n" (Map.size wadFlats)
printf "sprites: %d\n" (Map.size wadSprites)
printf "textures: %d\n" (Map.size wadTextures)
printf "patches: %d\n" (Map.size wadPatches)
printf "pnames: %d\n" (Map.size wadPNames)
forM_ (Map.elems wadLevels) $ \ level@Level{..} -> do
withFile (printf "%s/level-%s.js" dir (BS8.unpack levelName)) WriteMode $ \ h ->
exportLevel h level
withFile (printf "%s/levels.js" dir) WriteMode $ \ h ->
exportLevels h wadLevels
withFile (printf "%s/sprites.js" dir) WriteMode $ \ h ->
exportSprites h wadSprites
withFile (printf "%s/patches.js" dir) WriteMode $ \ h ->
exportPatches h wadPatches
withFile (printf "%s/textures.js" dir) WriteMode $ \ h ->
exportTextures h wadTextures
withFile (printf "%s/pnames.js" dir) WriteMode $ \ h ->
exportPNames h wadPNames
withFile (printf "%s/flats.js" dir) WriteMode $ \ h ->
exportFlats h wadFlats
withFile (printf "%s/colormap.js" dir) WriteMode $ \ h ->
exportColormap h wadColormap
withFile (printf "%s/palettes.js" dir) WriteMode $ \ h ->
exportPalettes h wadPalettes
return ()
exportThing :: Handle -> (String, Thing) -> IO ()
exportThing h (comma, Thing{..}) = do
hPrintf h " %s{x:%d,y:%d,angle:%d,type:\"%s\",flags:%d}\n" comma
thingX thingY thingAngle (show thingType) thingFlags
exportVertex :: Handle -> (String, Vertex) -> IO ()
exportVertex h (comma, Vertex{..}) = do
hPrintf h " %s{x:%d,y:%d}\n" comma
vertexX vertexY
exportLineDef :: Handle -> (String, LineDef) -> IO ()
exportLineDef h (comma, LineDef{..}) = do
hPrintf h " %s{start:%d,end:%d,flags:%d,effect:%d,tag:%d,right:%d,left:%s}\n" comma
lineDefStartVertex lineDefEndVertex lineDefFlags lineDefEffect lineDefTag
lineDefRightSideDef (maybe "null" show lineDefLeftSideDef)
exportSideDef :: Handle -> (String, SideDef) -> IO ()
exportSideDef h (comma, SideDef{..}) = do
hPrintf h " %s{xofs:%d,yofs:%d,upperTexture:%s,lowerTexture:%s,middleTexture:%s,sector:%d}\n" comma
sideDefXOffset sideDefYOffset (show sideDefUpperTextureName)
(show sideDefLowerTextureName) (show sideDefMiddleTextureName)
sideDefSector
exportNode :: Handle -> (String, Node) -> IO ()
exportNode h (comma, Node{..}) = do
hPrintf h " %s{x:%d,y:%d,dx:%d,dy:%d,rbbuy:%d,rbbly:%d,rbblx:%d,rbbux:%d,lbbuy:%d,lbbly:%d,lbblx:%d,lbbux:%d,rightNodeOrSSector:%d,leftNodeOrSSector:%d}\n" comma
nodeX nodeY nodeDX nodeDY
nodeRightBBUY nodeRightBBLY nodeRightBBLX nodeRightBBUX
nodeLeftBBUY nodeLeftBBLY nodeLeftBBLX nodeLeftBBUX
((either fromIntegral ((.|. 0x8000) . fromIntegral) nodeRightNodeOrSSector) :: Word16)
((either fromIntegral ((.|. 0x8000) . fromIntegral) nodeLeftNodeOrSSector) :: Word16)
exportSector :: Handle -> (String, Sector) -> IO ()
exportSector h (comma, Sector{..}) = do
hPrintf h " %s{floorHeight:%d,ceilingHeight:%d,floorFlat:%s,ceilingFlat:%s,lightLevel:%d,special:%d,tag:%d}\n" comma
sectorFloorHeight sectorCeilingHeight (show sectorFloorFlat) (show sectorCeilingFlat)
sectorLightLevel sectorSpecial sectorTag
exportSeg :: Handle -> (String, Seg) -> IO ()
exportSeg h (comma, Seg{..}) = do
hPrintf h " %s{start:%d,end:%d,angle:%d,lineDef:%d,direction:%d,offset:%d}\n" comma
segStartVertex segEndVertex segAngle segLineDef segDirection segOffset
exportSSector :: Handle -> (String, SSector) -> IO ()
exportSSector h (comma, SSector{..}) = do
hPrintf h " %s{segCount:%d,segStart:%d}\n" comma
ssectorSegCount ssectorSegStart
exportBlockmap :: Handle -> Maybe Blockmap -> IO ()
exportBlockmap h Nothing = hPrintf h "null"
exportBlockmap h (Just Blockmap{..}) = do
hPrintf h " {originX:%d,originY:%d,columns:%d,rows:%d,\n"
blockmapOriginX blockmapOriginY blockmapColumns blockmapRows
hPrintf h " offsets:%s,\n lists:%s}"
(show blockmapOffsets) (show blockmapBlocklists)
exportLevel :: Handle -> Level -> IO ()
exportLevel h Level{..} = do
hPrintf h "var level_%s = {\n" (BS8.unpack levelName)
hPrintf h " things: [\n"
mapM_ (exportThing h) (zip (" ":repeat ",") levelThings)
hPrintf h " ],\n"
hPrintf h " vertices: [\n"
mapM_ (exportVertex h) (zip (" ":repeat ",") levelVertices)
hPrintf h " ],\n"
hPrintf h " linedefs: [\n"
mapM_ (exportLineDef h) (zip (" ":repeat ",") levelLineDefs)
hPrintf h " ],\n"
hPrintf h " sidedefs: [\n"
mapM_ (exportSideDef h) (zip (" ":repeat ",") levelSideDefs)
hPrintf h " ],\n"
hPrintf h " segs: [\n"
mapM_ (exportSeg h) (zip (" ":repeat ",") levelSegs)
hPrintf h " ],\n"
hPrintf h " ssectors: [\n"
mapM_ (exportSSector h) (zip (" ":repeat ",") levelSSectors)
hPrintf h " ],\n"
hPrintf h " sectors: [\n"
mapM_ (exportSector h) (zip (" ":repeat ",") levelSectors)
hPrintf h " ],\n"
hPrintf h " nodes: [\n"
mapM_ (exportNode h) (zip (" ":repeat ",") levelNodes)
hPrintf h " ],\n"
hPrintf h " reject: %s,\n" (maybe "[]" (show . BS.unpack . rejectBytes) levelReject)
hPrintf h " blockmap: \n"
exportBlockmap h levelBlockmap
hPrintf h "\n"
hPrintf h "};\n"
exportLevels :: Handle -> Map (CI LumpName) Level -> IO ()
exportLevels h mp = do
hPrintf h "var levels = {%s};\n"
(intercalate (","::String) $ (map (\ (_, Level{..}) ->
printf "%s: level_%s" (show levelName) (BS8.unpack levelName))
(zip ((" "::String):repeat",") $ Map.elems mp)))
exportPicture :: Handle -> Picture -> IO ()
exportPicture h Picture{..} = do
hPrintf h " width:%d,height:%d,leftOffset:%d,topOffset:%d,columns:[\n" pictureWidth pictureHeight pictureLeftOffset pictureTopOffset
forM_ (zip (" ":repeat ",") picturePosts) $ \ (comma1, plist) -> do
hPrintf h " %s[" (comma1 :: String)
forM_ (zip (" ":repeat ",") plist) $ \ (comma, Post{..}) -> do
hPrintf h "%s{top:%d,pixels:%s}" (comma::String) postTop (show (BS.unpack postPixels))
hPrintf h "]\n"
hPrintf h " ]"
exportSprite :: Handle -> (String, (CI LumpName, Sprite)) -> IO ()
exportSprite h (comma1, (_, Sprite{..})) = do
hPrintf h " %s%s: {name: %s,\n" comma1 (show spriteName) (show spriteName)
exportPicture h spritePicture
hPrintf h "\n }\n"
exportSprites :: Handle -> Map (CI LumpName) Sprite -> IO ()
exportSprites h mp = do
hPrintf h "var sprites = {\n"
forM_ (zip (" ":repeat ",") $ Map.toList mp) (exportSprite h)
hPrintf h " };\n"
exportPatch :: Handle -> (String, (CI LumpName, Patch)) -> IO ()
exportPatch h (comma1, (_, Patch{..})) = do
hPrintf h " %s%s: {name: %s,\n" comma1 (show patchName) (show patchName)
exportPicture h patchPicture
hPrintf h "\n }\n"
exportPatches :: Handle -> Map (CI LumpName) Patch -> IO ()
exportPatches h mp = do
hPrintf h "var patches = {\n"
forM_ (zip (" ":repeat ",") $ Map.toList mp) (exportPatch h)
hPrintf h "};\n"
exportTexture :: Handle -> (String, (CI LumpName, Texture)) -> IO ()
exportTexture h (comma1, (_, Texture{..})) = do
hPrintf h " %s%s: {name:%s,width:%d,height:%d,patches:[\n" comma1 (show textureName) (show textureName) textureWidth textureHeight
forM_ (zip (" ":repeat ",") texturePatchDescriptors) $ \ (comma, PatchDescriptor{..}) ->
hPrintf h " %s{xoffset:%d,yoffset:%d,pname:%d,stepdir:%d,colormap:%d}\n" (comma :: String)
patchDescriptorXOffset patchDescriptorYOffset patchDescriptorPNameIndex patchDescriptorStepDir patchDescriptorColorMap
hPrintf h " ]}\n"
exportTextures :: Handle -> Map (CI LumpName) Texture -> IO ()
exportTextures h mp = do
hPrintf h "var textures = {\n"
forM_ (zip (" ":repeat ",") $ Map.toList mp) (exportTexture h)
hPrintf h "};\n"
exportPNames :: Handle -> Map Int LumpName -> IO ()
exportPNames h mp = do
hPrintf h "var pnames = [\n"
forM_ (zip (" " : repeat ",") $ Map.elems mp) $ \ (comma, ln) -> do
hPrintf h "%s%s" (comma :: String) (show ln)
hPrintf h " ];\n"
exportFlats :: Handle -> Map (CI LumpName) Flat -> IO ()
exportFlats h mp = do
hPrintf h "var flats = {\n"
forM_ (zip (" ":repeat ",") (Map.elems mp)) $ \ (comma, Flat{..}) -> do
hPrintf h " %s%s:{name:%s,data:%s}\n" (comma :: String)
(show flatName) (show flatName) (show (BS.unpack flatData))
hPrintf h " }\n"
exportColormap :: Handle -> Maybe Colormap -> IO ()
exportColormap _ Nothing = return ()
exportColormap h (Just (Colormap bs)) = do
hPrintf h "var colormap = \n"
hPrintf h " %s\n" (show (map BS.unpack bs))
hPrintf h " ;\n"
exportPalettes :: Handle -> Maybe Palettes -> IO ()
exportPalettes _ Nothing = return ()
exportPalettes h (Just (Palettes pals)) = do
hPrintf h "var palettes = [\n"
forM_ (zip (" ":repeat ",") pals) $ \ (comma, pal) -> do
hPrintf h " %s[" (comma :: String)
forM_ (zip (" ":repeat ",") pal) $ \ (comma', (r,g,b)) -> do
hPrintf h "%s[%d,%d,%d]" (comma' :: String) r g b
hPrintf h "]\n"
hPrintf h " ];\n"