DoomWad.elm

import Array exposing (Array)
import Array.Extra as Array
import Bitwise
import Bytes exposing (Bytes, Endianness(..))
import Bytes.Decode as Decode exposing (Decoder)
import Bytes.Decode.Extra as Decode
import Bytes.Encode as Encode
import Dict exposing (Dict)
import Dict.Extra
import List.Extra as List
import Maybe.Extra as Maybe
import Png exposing (Png)
import Result.Extra as Result
import Set exposing (Set)


type alias MapTexture =
    { name : String
    , width : Int
    , height : Int
    , patches : Array MapPatch
    }


type alias MapPatch =
    { originX : Int
    , originY : Int
    , patchNumber : Int
    }


type alias Patch =
    { width : Int
    , height : Int
    , leftOffset : Int
    , topOffset : Int
    , columns : Array (Array Post)
    }


type alias Post =
    { topDelta : Int
    , length : Int

    -- Array of pixel byte values
    , data : Array Int
    }


buildTexturePixels : String -> Bool -> Array Patch -> Palette -> MapTexture -> { width : Int, height : Int, pixels : Bytes }
buildTexturePixels name autoResize patches playpal mapTexture =
    let
        texturePatches : Array ( Int, Int, Patch )
        texturePatches =
            (if name == "EXITDOOR" then
                mapTexture.patches
                    -- Peg the (72px high) door texture to the bottom of the
                    -- actual surface, since that's how the map designs expect
                    -- it. But don't move the other patches (the doorjamb), as
                    -- they need to remain at the top of the texture.
                    |> Array.update 0 (\mapPatch -> { mapPatch | originY = 56 })

             else
                mapTexture.patches
            )
                |> Array.filterMap
                    (\{ originX, originY, patchNumber } ->
                        Array.get patchNumber patches
                            |> Maybe.map (\patch -> ( originX, originY, patch ))
                    )

        background : Int
        background =
            -- Start with a non-transparent background for non-power-of-two
            -- textures to fix a transparent pixel blending issue at the top
            -- edge, that causes a "crack" at the top of the wall where the
            -- texture is drawn.
            if List.member name [ "COMPUTE2", "DOOR3", "EXITDOOR", "NUKE24" ] then
                0

            else
                -- -1 is a handy value that causes us an Array.get to fail, making us
                -- fall-back to writing a transparent pixel, below.
                -1

        actualHeight : Int
        actualHeight =
            if autoResize then
                heightToPowerOf2 mapTexture.height

            else
                mapTexture.height

        -- An array of COLUMNS of pixels, rather than an array of rows of pixels.
        blankColumns : Array (Array Int)
        blankColumns =
            Array.repeat mapTexture.width
                (Array.repeat actualHeight background)
    in
    texturePatches
        |> Array.foldl
            (\( originX, originY, patch ) pixels ->
                patch.columns
                    |> Array.toList
                    |> List.indexedFoldr
                        (\index posts pixels_ ->
                            let
                                x : Int
                                x =
                                    -- If x is out of bounds, Array.update is a no-op.
                                    originX + index
                            in
                            posts
                                |> Array.foldl
                                    (\post pixels__ ->
                                        pixels__
                                            |> Array.update x
                                                (\column ->
                                                    let
                                                        y : Int
                                                        y =
                                                            originY + post.topDelta
                                                    in
                                                    if y < 0 then
                                                        Array.append
                                                            (Array.sliceFrom -y post.data
                                                                -- make sure it doesn't get taller
                                                                |> Array.slice 0 actualHeight
                                                            )
                                                            (Array.sliceFrom (y + post.length) column)
                                                            |> Array.slice 0 actualHeight

                                                    else if y > actualHeight then
                                                        column

                                                    else
                                                        Array.append
                                                            (Array.append
                                                                (Array.slice 0 y column)
                                                                post.data
                                                                -- make sure it doesn't get taller
                                                                |> Array.slice 0 actualHeight
                                                            )
                                                            (Array.sliceFrom (y + post.length) column)
                                                )
                                    )
                                    pixels_
                        )
                        pixels
            )
            blankColumns
        |> rotateAndEncodeTexture
            { width = mapTexture.width
            , height = actualHeight
            , playpal = playpal
            }
        |> (\pixels ->
                { width = mapTexture.width, height = actualHeight, pixels = pixels }
           )


rotateAndEncodeTexture : { a | height : Int, width : Int, playpal : Palette } -> Array (Array Int) -> Bytes
rotateAndEncodeTexture { height, width, playpal } columns =
    Array.repeat (height * width) 0
        |> Array.indexedMapToList
            (\index _ ->
                let
                    column : Int
                    column =
                        index |> modBy width

                    row : Int
                    row =
                        index // width

                    pixel : Int
                    pixel =
                        columns
                            |> Array.get column
                            |> Maybe.andThen (Array.get row)
                            |> Maybe.withDefault 64
                in
                Array.get pixel playpal
                    |> Maybe.withDefault { r = 0, g = 0, b = 0, a = 0 }
                    |> (\p ->
                            Encode.unsignedInt32 BE
                                (Bitwise.shiftLeftBy 24 p.r
                                    |> Bitwise.or (Bitwise.shiftLeftBy 16 p.g)
                                    |> Bitwise.or (Bitwise.shiftLeftBy 8 p.b)
                                    |> Bitwise.or (Bitwise.shiftLeftBy 0 p.a)
                                )
                       )
            )
        |> Encode.sequence
        |> Encode.encode


heightToPowerOf2 : Int -> Int
heightToPowerOf2 height =
    let
        logBase2 : Float
        logBase2 =
            Basics.logBase 2 (toFloat height)
    in
    if logBase2 == (truncate logBase2 |> toFloat) then
        height

    else
        2 ^ Basics.ceiling logBase2