tools/hwmap.hs
author Wuzzy <almikes@aol.com>
Mon, 25 Sep 2017 20:09:33 +0200
changeset 12525 22f2a586b9ca
parent 11015 7a905f0070ce
permissions -rw-r--r--
Remove checkpoints in ASA: Getting to the device This means the player now must win this mission in one go. Justification: There were many ways for the mission to be saved in an unwinnable state, there are many ways to win this mission and the checkpoints try to "force" one particular way. Also, this mission isn't too long anyway.

module Main where

import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString as BW
import qualified Data.ByteString.Lazy as BL
import qualified Codec.Binary.Base64 as Base64
import Data.Word
import Data.Int
import Data.Binary
import Data.Binary.Put
import Data.Bits
import Control.Monad
import qualified Codec.Compression.Zlib as Z

data LineType = Solid | Erasing
    deriving Eq

data Chunk = SpecialPoints [(Int16, Int16)]
    | Line LineType Word8 [(Int16, Int16)]

transform :: ((Int16, Int16) -> (Int16, Int16)) -> [Chunk] -> [Chunk]
transform f = map tf
    where
    tf (SpecialPoints p) = SpecialPoints $ map f p
    tf (Line t r p) = Line t r $ map f p

scale f = transform (\(a, b) -> (a * f, b * f))
mirror = transform (\(a, b) -> (4095 - a, b))
flip' = transform (\(a, b) -> (a, 2047 - b))
translate dx dy = transform (\(a, b) -> (a + dx, b + dy))

instance Binary Chunk where
    put (SpecialPoints p) = do
        forM_ p $ \(x, y) -> do
            put x
            put y
            putWord8 0
    put (Line lt r ((x1, y1):ps)) = do
        let flags = r .|. (if lt == Solid then 0 else (1 `shift` 6))
        put x1
        put y1
        putWord8 $ flags .|. (1 `shift` 7)
        forM_ ps $ \(x, y) -> do
            put x
            put y
            putWord8 flags
    get = undefined

compressWithLength :: BL.ByteString -> BL.ByteString
compressWithLength b = BL.drop 8 . encode . runPut $ do
    put $ ((fromIntegral $ BL.length b)::Word32)
    mapM_ putWord8 $ BW.unpack $ BL.toStrict $ Z.compress b

mapString :: B.ByteString
mapString = B.pack . Base64.encode . BW.unpack . BL.toStrict . compressWithLength . BL.drop 8 . encode $ drawnMap05

main = B.writeFile "out.hwmap" mapString

drawnMap01 = translate (-3) (-3) $ sp ++ mirror sp ++ base ++ mirror base
    where
    sp = translate 128 128 . scale 256 $ [SpecialPoints [
        (6, 0)
        , (1, 4)
        , (4, 7)
        , (7, 5)
        ]]
    base = scale 256 $ [
        l [(5, 0), (5, 1)]
        , l [(7, 0), (7, 1)]
        , l [(8, 1), (6, 1), (6, 4)]
        , l [(8, 1), (8, 6), (6, 6), (6, 7), (8, 7)]
        , l [(7, 2), (7, 5), (5, 5)]
        , l [(5, 3), (5, 8)]
        , l [(6, 2), (4, 2)]
        , l [(1, 1), (4, 1), (4, 7)]
        , l [(3, 5), (3, 7), (2, 7), (2, 8)]
        , l [(2, 1), (2, 2)]
        , l [(0, 2), (1, 2), (1, 3), (3, 3), (3, 2)]
        , l [(0, 5), (1, 5)]
        , l [(1, 4), (4, 4)]
        , l [(2, 4), (2, 6), (1, 6), (1, 7)]
        , l [(0, 8), (8, 8)]
        ]
    l = Line Solid 0

drawnMap02 = translate (-3) (-3) $ sp ++ mirror sp ++ base ++ mirror base
    where
    sp = translate 128 128 . scale 256 $ [SpecialPoints [
        (7, 0)
        , (7, 7)
        ]]
    base = scale 256 $ [
        l [(8, 0), (8, 1), (1, 1)]
        , l [(2, 1), (2, 2), (3, 2), (3, 3), (4, 3), (4, 4), (5, 4), (5, 5), (6, 5), (6, 6), (7, 6), (7, 7), (7, 1)]
        , l [(0, 2), (1, 2), (1, 3), (2, 3), (2, 4), (3, 4), (3, 5), (4, 5), (4, 6), (5, 6), (5, 7), (6, 7), (6, 8), (8, 8), (8, 2)]
        ]
    l = Line Solid 0


drawnMap03 = translate (-3) (-3) $ sp ++ mirror sp ++ base ++ mirror base
    where
    sp = translate 128 128 . scale 256 $ [SpecialPoints [
        (3, 1)
        , (2, 4)
        ]]
    base = scale 256 $ [
        l [(6, 0), (6, 1)]
        , l [(1, 1), (5, 1)]
        , l [(4, 1), (4, 2), (3, 2)]
        , l [(0, 2), (1, 2), (1, 4)]
        , l [(0, 4), (3, 4), (3, 3), (5, 3), (5, 2), (7, 2)]
        , l [(7, 1), (7, 3)]
        , l [(8, 0), (8, 4), (4, 4), (4, 5), (1, 5), (1, 6)]
        , l [(6, 3), (6, 4)]
        , l [(0, 8), (8, 8)]
        , l [(1, 7), (1, 8)]
        , l [(2, 7), (2, 5)]
        , l [(3, 6), (3, 5)]
        , l [(3, 7), (3, 8)]
        , l [(4, 6), (4, 8)]
        , l [(5, 4), (5, 6)]
        , l [(5, 7), (5, 8)]
        , l [(6, 5), (6, 8)]
        , l [(7, 4), (7, 6)]
        , l [(7, 7), (7, 8)]
        , l [(8, 5), (8, 8)]
        ]
    l = Line Solid 0

drawnMap04 = translate (-3) (-3) $ sp ++ fm sp ++ base ++ fm base
    where
    sp = translate 128 128 . scale 256 $ [SpecialPoints [
        (7, 7)
--        , (6, 6)
        , (3, 3)
        , (0, 6)
        , (3, 6)
        ]]
    base = scale 256 $ [
        l [(1, 2), (3, 2), (3, 1), (4, 1), (4, 2), (6, 2), (6, 4), (7, 4), (7, 5), (8, 5), (8, 8)]
        , l [(0, 0), (16, 0)]
        , l [(1, 5), (3, 5), (3, 7), (1, 7), (1, 5)]
        , l [(4, 5), (6, 5), (6, 7), (4, 7), (4, 5)]
        , l [(0, 4), (2, 4), (2, 3), (5, 3), (5, 4)]
        , l [(6, 1), (6, 2), (7, 2)]
        , l [(7, 1), (8, 1)]
        , l [(7, 3), (8, 3)]
        , l [(3, 4), (4, 4)]
        , l [(7, 6), (7, 8)]
        , l [(2, 0), (2, 1)]
        , l [(5, 0), (5, 1)]
        ]
    l = Line Solid 0
    fm = flip' . mirror

drawnMap05 = sp ++ fullFill ++ lW
    where
        w = 320
        sh = 420
        basePoints = [(w, w), (1024 + w `div` 2, 2048 - w), (2048, w), (3072 - w `div` 2, 2048 - w), (4096 - w, w)]
        lW = [Line Erasing 60 basePoints]
        sp = [SpecialPoints $ basePoints ++ [(1024 + w `div` 2, 2048 - w - sh), (3072 - w `div` 2, 2048 - w - sh), (2048, w + sh)]]

fullFill = scale 256 $ [Line Solid 63 [(0, 1), (16, 1), (16, 3), (0, 3), (0, 5), (16, 5), (16, 7), (0, 7)]]