{-# OPTIONS_GHC -F -pgmF htfpp #-}
{-# OPTIONS_HADDOCK prune #-}

{-|
Module      : Liquorice.Wad
Description : Data types modelling Doom internal data structures
Copyright   : © Jonathan Dowland, 2020
License     : GPL-3
Maintainer  : jon+hackage@dow.land
Stability   : experimental
Portability : POSIX

Data types that model the internal data structures in Doom to represent
maps, as well as an interim data-type (`WadMap`) to bridge between these
and Liquorice's more abstract types.
-}
module Liquorice.Wad ( WadLump(..)
                     , wadLumpLength
                     , wadLumpName
                     , Linedef(..)
                     , Sidedef(..)
                     , WadMap(..)
                     , mapWad2Wad
                     , dumpWad

                     , htf_thisModulesTests
                     ) where

import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LC
import Data.Binary
import Data.Binary.Put
import Test.Framework

import Liquorice

-- local cheats
str8 :: String -> L.ByteString
str8 s = let bit = take 8 s
             len = length bit
             pad = take (8 - len) (repeat '\0')
         in
            LC.pack $ bit ++ pad

putShort = putInt16le . fromIntegral
putInt   = putInt32le . fromIntegral

-- data structures to closely represent WAD lumps ----------------------------

-- | Enumeration (of sorts) of supported WAD lump types.
data WadLump = WadLabel String
             | WadThings [Thing]   -- re-used from Liquorice
             | WadVertexes [Point] -- re-used from Liquorice
             | WadSectors [Sector] -- re-used from Liquorice (but might not want to)
             | WadLinedefs [Linedef]
             | WadSidedefs [Sidedef]
             | WadLump String L.ByteString deriving (Show)

-- | Calculate the lump length of a given WadLump type.
wadLumpLength :: WadLump -> Int
wadLumpLength (WadLabel _)     = 0
wadLumpLength (WadThings ts)   = 10 * length ts
wadLumpLength (WadLump _ l)    = fromIntegral (LC.length l)
wadLumpLength (WadVertexes vs) = 4 * length vs
wadLumpLength (WadSectors ss)  = 26 * length ss
wadLumpLength (WadLinedefs ls) = 14 * length ls
wadLumpLength (WadSidedefs ss) = 30 * length ss

-- | Determine the lump name for a given WadLump.
wadLumpName :: WadLump -> String
wadLumpName (WadLabel s) = s
wadLumpName (WadThings _) = "THINGS"
wadLumpName (WadVertexes _) = "VERTEXES"
wadLumpName (WadSectors _) = "SECTORS"
wadLumpName (WadLinedefs _)= "LINEDEFS"
wadLumpName (WadSidedefs _)= "SIDEDEFS"
wadLumpName (WadLump s _) = s

-- | A Doom Line definition.
data Linedef = Linedef { ldFrom    :: Int -- all shorts
                       , ldTo      :: Int
                       , ldFlags   :: Int
                       , ldSpecial :: Int
                       , ldTag     :: Int
                       , ldFront   :: Int
                       , ldBack    :: Int
                       } deriving (Show, Eq)

-- | A Doom Line "Side" definition.
data Sidedef = Sidedef { sdXoff   :: Int -- shorts or 8-byte strings
                       , sdYoff   :: Int
                       , sdUpper  :: String
                       , sdLower  :: String
                       , sdMid    :: String
                       , sdSector :: Int
                       } deriving (Show, Eq)

-- converting those data structures to ByteStrings ---------------------------

nope = error "not implemented"

instance Binary WadLump where
    get = nope
    put (WadLabel l)     = return ()
    put (WadLump _ d)    = put d -- XXX probably wrong! we want some literal put
    put (WadThings ts)   = mapM_ put ts
    put (WadVertexes vs) = mapM_ (\ (x,y) -> (putShort x >> putShort y)) vs
    put (WadSectors ss)  = mapM_ put ss
    put (WadLinedefs ls) = mapM_ put ls
    put (WadSidedefs ss) = mapM_ put ss

instance Binary Sector where
    get = nope
    put (Sector f c fflat cflat ll stype tag _) = do
        putShort f
        putShort c
        putLazyByteString (str8 fflat)
        putLazyByteString (str8 cflat)
        putShort ll
        putShort stype
        putShort tag

instance Binary Linedef where
    get = nope
    put (Linedef from to flags special tag front back) = do
       putShort from
       putShort to
       putShort flags
       putShort special
       putShort tag
       putShort front
       putShort back

instance Binary Sidedef where
    get = nope
    put (Sidedef xoff yoff upper lower mid sector) = do
        putShort xoff
        putShort yoff
        putLazyByteString (str8 upper)
        putLazyByteString (str8 lower)
        putLazyByteString (str8 mid)
        putShort sector

instance Binary Thing where
    get = nope
    put (Thing (x,y) angle ty flags) = do
        putShort x
        putShort y
        putShort angle
        putShort ty
        putShort flags

wadHeader :: Int -> Int -> L.ByteString
wadHeader numents diroffs = runPut $ do
    putStringUtf8 "PWAD"
    putInt numents
    putInt diroffs

-- convert a directory into bytes to write out
dumpWadDir :: [(Int,Int,String)] -> L.ByteString
dumpWadDir xs = L.concat (map dumpWadDir' xs) where
    dumpWadDir' :: (Int,Int,String) -> L.ByteString
    dumpWadDir' (offs,len,name) = runPut $ do
        putInt offs
        putInt len
        putLazyByteString (str8 name)

-- | Convert a list of `WadLump`s into a PWAD represented as a Lazy
-- `ByteString`.
dumpWad :: [WadLump] -> L.ByteString
dumpWad ws = let numents = length ws
                 diroffs = 12 + sum (map wadLumpLength ws)
                 header  = wadHeader numents diroffs
                 dir     = dumpWadDir (buildWadDir ws)
             in  L.concat (header : (map encode ws) ++ [dir])
-- XXX: rename

buildWadDir :: [WadLump] -> [(Int,Int,String)] -- offs,len,name
buildWadDir ws = buildWadDir' 12 ws where
    buildWadDir' :: Int -> [WadLump] -> [(Int,Int,String)]
    buildWadDir' _ [] = []
    buildWadDir' offs (w:ws) = let len = wadLumpLength w
                               in (offs, len, wadLumpName w):(buildWadDir' (offs+len) ws)

-- similar to above; but exactly one map-related lump ------------------------

-- | A representation of all the WAD lumps that are required for a Doom map.
data WadMap = WadMap { mapLabel        :: String
                     , mapThings       :: [Thing]
                     , mapLinedefs     :: [Linedef]
                     , mapSidedefs     :: [Sidedef]
                     , mapVertexes     :: [Point]
                     , mapSectors      :: [Sector]
                     } deriving (Show, Eq)

-- | Process a `WadMap` into a list of `WadLumps` that could be written to
-- a PWAD.
mapWad2Wad :: WadMap -> [WadLump]
mapWad2Wad (WadMap label things lines sides vertexes sectors) =
    [ WadLabel label, WadThings things, WadLinedefs lines,
      WadSidedefs sides, WadVertexes vertexes, WadSectors sectors ]

-- | Convert a `WadMap` into a list of lumps and dump them into a PWAD.
buildMapWad :: WadMap -> L.ByteString
buildMapWad = dumpWad . mapWad2Wad

-- test data - raw PWAD read into a ByteString -------------------------------

main = htfMain htf_thisModulesTests
wad1 = LC.pack "PWAD\ACK\NUL\NUL\NUL\192\NUL\NUL\NUL \NUL@\NULZ\NUL\SOH\NUL\NUL\NUL\NUL\NUL\SOH\NUL\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\255\255\STX\NUL\NUL\NUL\SOH\NUL\NUL\NUL\NUL\NUL\SOH\NUL\255\255\SOH\NUL\STX\NUL\SOH\NUL\NUL\NUL\NUL\NUL\STX\NUL\255\255\NUL\NUL\NUL\NUL-\NUL\NUL\NUL\NUL\NUL\NUL\NUL-\NUL\NUL\NUL\NUL\NUL\NUL\NULZZWOLF3\NUL\NUL\NUL\NUL\NUL\NUL\NUL-\NUL\NUL\NUL\NUL\NUL\NUL\NUL-\NUL\NUL\NUL\NUL\NUL\NUL\NULZZWOLF2\NUL\NUL\NUL\NUL\NUL\NUL\NUL-\NUL\NUL\NUL\NUL\NUL\NUL\NUL-\NUL\NUL\NUL\NUL\NUL\NUL\NULZZWOLF1\NUL\NUL\NUL\128\NUL\128\NUL\NUL\NUL\NUL\NUL\NUL\NUL\128\NUL\NUL\NUL\128\NULFLAT23\NUL\NULF_SKY1\NUL\NUL\160\NUL\NUL\NUL\NUL\NUL\f\NUL\NUL\NUL\NUL\NUL\NUL\NULMAP01\NUL\NUL\NUL\f\NUL\NUL\NUL\n\NUL\NUL\NULTHINGS\NUL\NUL\SYN\NUL\NUL\NUL*\NUL\NUL\NULLINEDEFS@\NUL\NUL\NULZ\NUL\NUL\NULSIDEDEFS\154\NUL\NUL\NUL\f\NUL\NUL\NULVERTEXES\166\NUL\NUL\NUL\SUB\NUL\NUL\NULSECTORS\NUL"

wad8 :: [WadLump]
wad8 = [ WadLabel "MAP01"
       , WadThings [Thing (32,64) 90 1 0]
       , WadLinedefs [ Linedef 0 1 1 0 0 0 (-1)
                     , Linedef 2 0 1 0 0 1 (-1)
                     , Linedef 1 2 1 0 0 2 (-1) ]
       , WadSidedefs [ Sidedef 0 0 "-" "-" "ZZWOLF3" 0
                     , Sidedef 0 0 "-" "-" "ZZWOLF2" 0
                     , Sidedef 0 0 "-" "-" "ZZWOLF1" 0 ]
       , WadVertexes [(128,128), (0,0), (0,128)]
       , WadSectors [Sector 0 128 "FLAT23" "F_SKY1" 160 0 0 [] ]
       ]

test_equiv8 = assertEqual (dumpWad wad8) wad1

wad9 = WadMap { mapLabel    = "MAP01"
              , mapThings   = [Thing (32, 64) 90 1 0]
              , mapLinedefs = [ Linedef 0 1 1 0 0 0 (-1)
                              , Linedef 2 0 1 0 0 1 (-1)
                              , Linedef 1 2 1 0 0 2 (-1) ]
              , mapSidedefs = [ Sidedef 0 0 "-" "-" "ZZWOLF3" 0
                              , Sidedef 0 0 "-" "-" "ZZWOLF2" 0
                              , Sidedef 0 0 "-" "-" "ZZWOLF1" 0 ]
              , mapVertexes = [(128, 128), (0, 0), (0, 128)]
              , mapSectors  = [Sector 0 128 "FLAT23" "F_SKY1" 160 0 0 [] ]
              }

test_equiv9 = assertEqual ((dumpWad . mapWad2Wad) wad9) wad1