module Main where

import Data.Bool (bool)
import Data.Maybe (fromMaybe)
import Data.List (stripPrefix, isPrefixOf, findIndex, genericIndex)
import Data.Char (ord)
import Data.Word (Word8)
import qualified Data.ByteString as B
import Transform

animate :: [(String, Transform -> Transform)] -> String -> [String] 
animate a s = map svg $ scanl (flip applyAnim) (parseInput s) $ map (:[]) a

paint :: String -> String
paint = svg . parseInput


-----
-- Animating drawings

-- At first, I misinterpreted the assignment: I thought the first argument to animate were
-- a map from id to transform function; and animate should produce an infinite list,
-- where each element is another step of applying all animator functions to the drawing.
-- But for an idea I have for the Wettbewerb, this behaviour is rather useful.
-- This is why the following code is written the way it is.

applyAnim :: [(String, Transform -> Transform)] -> Drawing -> Drawing
applyAnim a (Drawing gs) = Drawing $ map (applyAnimGroup a) gs

applyAnimGroup :: [(String, Transform -> Transform)] -> Group -> Group
applyAnimGroup a (Group shapes id tr) = Group (map (applyAnimShape a) shapes) id $ applyAnimTransform id a tr

applyAnimShape :: [(String, Transform -> Transform)] -> Shape -> Shape
applyAnimShape a (Shape t d1 d2 id tr) = Shape t d1 d2 id $ applyAnimTransform id a tr

applyAnimTransform :: String -> [(String, Transform -> Transform)] -> Transform -> Transform
applyAnimTransform i = fromMaybe id . lookup i


-----
-- Input parsing

parseInput :: String -> Drawing
parseInput s = Drawing $ parseGroups (lines s) []

-- First argument: remaining lines.
-- Second argument: parsed groups so far, in reverse order. (head is the "active" group)
-- Result: The parsed groups, in correct order.
parseGroups :: [String] -> [Group] -> [Group]
parseGroups [] gs = reverse gs
parseGroups (l:ls) gs = case parseGroup l of
  Just gid -> parseGroups ls $ (Group [] gid defaultTransform):gs
  Nothing -> case gs of
    [] -> error "First input line has to be a group line"
    ((Group shapes gid tr):gs) -> case parseShape $ words l of
      Nothing -> error $ "Illegal line: \"" ++ l ++ "\""
      Just s -> parseGroups ls $ (Group (s:shapes) gid tr):gs

parseGroup :: String -> Maybe String
parseGroup l = maybe Nothing (\g -> if g == [] then Nothing else if last g == ':' then Just $ init g else Nothing) $ stripPrefix "group " l

parseShape :: [String] -> Maybe Shape
parseShape (["rectangle",id,ws,hs]) = Just $ Shape Rectangle (read ws) (read hs) id defaultTransform
parseShape (["ellipse",id,rxs,rys]) = Just $ Shape Ellipse (read rxs) (read rys) id defaultTransform
parseShape _ = Nothing


-----
-- SVG representation and serializing

-- I wanted to keep a more "human-readable" Show instance for my data types than their SVG representation
class SVG a where
  svg :: a -> String

instance SVG Transform where
  svg Transform {rotate=rotate, scale=(sx,sy), translate=(tx,ty)} = "rotate(" ++ (show rotate) ++
    ") scale(" ++ (show $ sx) ++ " " ++ (show $ sy) ++ ") translate(" ++ (show tx) ++ " " ++ (show ty) ++ ")"

data ShapeType = Rectangle | Ellipse
  deriving (Eq, Show)

-- TODO much duplication ahead...

data Shape = Shape ShapeType Double Double String Transform 
  deriving (Eq, Show)
instance SVG Shape where
  svg (Shape Rectangle w h ident transform) =
    "<rect" ++
    " id=\""         ++ ident           ++ "\"" ++
    " width=\""      ++ (show w)        ++ "\"" ++
    " height=\""     ++ (show h)        ++ "\"" ++
    " transform =\"" ++ (svg transform) ++ "\"" ++
    " />"
  svg (Shape Ellipse rx ry ident transform) =
    "<ellipse" ++
    " id=\""         ++ ident           ++ "\"" ++
    " rx=\""         ++ (show rx)       ++ "\"" ++
    " ry=\""         ++ (show ry)       ++ "\"" ++
    " transform =\"" ++ (svg transform) ++ "\"" ++
    " />"

data Group = Group [Shape] String Transform
  deriving (Eq, Show)
instance SVG Group where
  svg (Group shapes ident transform) =
    "<g" ++
    " id=\""         ++ ident           ++ "\"" ++
    " transform =\"" ++ (svg transform) ++ "\"" ++
    ">" ++ (concatMap svg shapes) ++ "</g>"

newtype Drawing = Drawing [Group]
instance SVG Drawing where
  svg (Drawing groups) =
    "<svg xmlns=\"http://www.w3.org/2000/svg\">" ++
    concatMap svg groups ++
    "</svg>"
svgWithViewBox x y w h (Drawing groups) =
  "<svg viewBox=\"" ++ (show x) ++ " " ++ (show y) ++ " " ++ (show w) ++ " " ++ (show h) ++ "\" xmlns=\"http://www.w3.org/2000/svg\">" ++
  concatMap svg groups ++
  "</svg>"


-----
-- My Wettbewerb submission

{-WETT-}
-- Using m3x6 by Daniel Linssen (https://managore.itch.io/m3x6)

-- To run:
-- Just call main. A BMP file called "out.bmp" will be created.
-- Try to guess what this file contains before opening it :)
-- Note that the program does not use IO operations (except of course in main for writing the output file)

main :: IO ()
main = B.writeFile "out.bmp" submissionBMP

submissionBMP = toBMP [(255,255,255), (0,0,0), (127,127,127), (0,200,0), (0,0,255), (255,127,0), (255,0,255), (0,200,255), (127,0,127)] $ textToField (syntaxHighlight programSource) programSource

programSource = (take markerIndex programSourcePre) ++ (splitIntoLines $ escape programSourcePre) ++ (drop (markerIndex + 6) programSourcePre)

markerIndex = fromMaybe (error "Marker not found") $ indexOf ("MAR"++"KER") programSourcePre

-- Synatx highlighting

-- Generates a list of colors for each char, compatible with textToField
-- 1: default
-- 2: comments
-- 3: strings and chars
-- 4: ints
-- 5: identifiers of functions / constants
-- 6: identifiers of classes / types / constructors / constraints
-- 7: keywords
-- 8: built-ins
syntaxHighlight :: String -> [Integer]
syntaxHighlight = let
    digits  = "0123456789"
    hexDgt  = "0123456789abcdefABCDEF"
    id1St   = "abcdefghijklmnopqrstuvwxyz"
    id2St   = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    idPart  = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"
    kwords  = ["module", "where", "import", "qualified", "let", "in", "instance", "if", "then", "else", "case", "of", "deriving", "data", "newtype", "type"]
    builtin = ["bool", "fromMaybe", "stripPrefix", "isPrefixOf", "findIndex", "genericIndex", "ord", "map", "scanl", "flip", "lookup", "lines", "reverse",
      "words", "error", "maybe", "last", "init", "stripPrefix", "read", "show", "concatMap", "writeFile", "take", "drop", "length", "splitAt", "otherwise",
      "replicate", "maximum", "null", "fromIntegral", "head", "concat", "div", "pack", "divMod"]
    -- TODO make the following code shorter
    -- States:
    -- 0: default
    -- 1: in line comment
    -- 2: in multiline comment
    -- 3: in a string
    -- 4: in a string; next char escaped
    -- 5: in a char
    -- 6: in a char; next char escaped
    -- 7: in an identifier of functions / constants
    -- 8: in an identifier of classes / types / constructors / constraints
    -- 9: in a hex number
    aux :: Integer -> String -> [Integer]
    aux _ "" = []
    aux 0 ('-':'-':s) = 2:2 : aux 1 s
    aux 0 ('{':'-':s) = 2:2 : aux 2 s
    aux 0 ('"'    :s) = 3   : aux 3 s
    aux 0 ('\''   :s) = 3   : aux 5 s
    aux 0 ('0':'x':s) = 4:4 : aux 9 s
    aux 0 ('a':'s':' ':'B':'\n':s) = 7:7:1:6:1:aux 0 s
    aux 0 f@(c    :s) = case firstPrefixOfNotFollowedBy kwords  idPart f of
      Just p         -> (replicate (length p) 7) ++ (aux 0 (drop (length p) f))
      Nothing        -> case firstPrefixOfNotFollowedBy builtin idPart f of
        Just p         -> (replicate (length p) 8) ++ (aux 0 (drop (length p) f))
        Nothing        ->
          if elem c digits then 4   : aux 0 s else
          if elem c id1St  then 5   : aux 7 s else
          if elem c id2St  then 6   : aux 8 s else 1   : aux 0 s
    aux 1 ('\n'   :s) = 2   : aux 0 s
    aux 1 (c      :s) = 2   : aux 1 s
    aux 2 ('-':'}':s) = 2:2 : aux 0 s
    aux 2 (c      :s) = 2   : aux 2 s
    aux 3 ('"'    :s) = 3   : aux 0 s
    aux 3 ('\\'   :s) = 3   : aux 4 s
    aux 3 (c      :s) = 3   : aux 3 s
    aux 4 (c      :s) = 3   : aux 3 s
    aux 5 ('\''   :s) = 3   : aux 0 s
    aux 5 ('\\'   :s) = 3   : aux 6 s
    aux 5 (c      :s) = 3   : aux 5 s
    aux 6 (c      :s) = 3   : aux 5 s
    aux 7 f@(c    :s)
      | elem c idPart = 5   : aux 7 s
      | otherwise     =       aux 0 f
    aux 8 f@(c    :s)
      | elem c idPart = 6   : aux 8 s
      | otherwise     =       aux 0 f
    aux 9 f@(c    :s)
      | elem c hexDgt = 4   : aux 9 s
      | otherwise     =       aux 0 f
  in aux 0

-- BMP files

-- color = (red, greeen, blue) (no alpha)
type Color = (Word8, Word8, Word8)
type Palette = [Color]
-- image = [rows]; row = [0-based palette index]
type Image = [[Integer]]

toBMP :: Palette -> Image -> B.ByteString
toBMP pal img = let
    height = length img
    width = if height == 0 then 0 else length (head img)
    paletteEntries = length pal
    bitsPerPixel
      | paletteEntries <=   2 =  1 
      | paletteEntries <=  16 =  4 
      | paletteEntries <= 256 =  8
      | otherwise             = 24
    paletteLength
     | bitsPerPixel ==  1 =   2 * 3
     | bitsPerPixel ==  4 =  16 * 3
     | bitsPerPixel ==  8 = 256 * 3
     | bitsPerPixel == 24 = 0
    paletteData = if bitsPerPixel == 24 then [] else align paletteLength 0 (concatMap (\(r,g,b) -> [b,g,r]) pal)
    scanlineMapF row
      | bitsPerPixel ==  1 = map (decodeBaseBE  2) $ chunk 8 $ align 8 0 row
      | bitsPerPixel ==  4 = map (decodeBaseBE 16) $ chunk 2 $ align 2 0 row
      | bitsPerPixel ==  8 = map fromIntegral row
      | bitsPerPixel == 24 = concatMap (\(r,g,b) -> [b,g,r]) $ map (genericIndex pal) row
    scanlinesDataUnaligned = map scanlineMapF $ reverse img
    bitmapData = concat $ map (align 4 0) scanlinesDataUnaligned
    bitmapOffset = 26 + paletteLength
    totalSize = bitmapOffset + (div ((div (bitsPerPixel * width * height + 7) 8) + 3) 4) * 4
  in B.pack $ concat [
    -- BMP 2 header
    wordLE 0x4D42, dwordLE totalSize, wordLE 0, wordLE 0, dwordLE bitmapOffset,
    -- Bitmap header
    dwordLE 12, wordLE width, wordLE height, wordLE 1, wordLE bitsPerPixel,
    -- palette data (if any)
    paletteData,
    -- bitmap data
    bitmapData]

wordLE = nBytesLE 2
dwordLE = nBytesLE 4

nBytesLE :: Integral a => a -> a -> [Word8]
nBytesLE bits = let
    aux 0 _ = []
    aux b i = (fromIntegral i) : (aux (b-1) (div i 256))
  in aux bits

-- Font helper

-- [colors for each char] -> string to render -> field of colors, 0 for background
textToField :: [Integer] -> String -> [[Integer]]
textToField c s = let
    zipFirstNWith :: (a -> b -> b) -> [a] -> [b] -> [b]
    zipFirstNWith f = let
        aux [] bs = bs
        aux (a:as) (b:bs) = (f a b) : (aux as bs)
      in aux
    prependText :: [Integer] -> String -> [[Integer]] -> [[Integer]]
    prependText _ "" r = r
    prependText (  _:cols) ('\n':t) r = prependText cols t $ [0] : (replicate lettersH [0]) ++ r
    prependText (col:cols) (c   :t) r = prependText cols t $ zipFirstNWith (:) (replicate lettersH 0) $ zipFirstNWith (++) (map (map $ bool 0 col) $ decodeLetter c) r
    fieldUnaligned = [0] : (prependText (reverse c) (reverse s) $ replicate (lettersH+1) [0])
    width = maximum $ map length fieldUnaligned
  in map (align width 0) fieldUnaligned

decodeLetter :: Char -> [[Bool]]
decodeLetter c = let
    decodeLetterAux :: Int -> Int -> Int -> [[Bool]]
    decodeLetterAux x y b = let
        (d,r) = divMod b 2
        (s:t) = if x /= (letterW c) - 1 then decodeLetterAux (x+1) y d else if y /= lettersH - 1 then []:(decodeLetterAux 0 (y+1) d) else [[]]
      in ((r /= 0):s):t
  in decodeLetterAux 0 0 $ lettersB !! letterI c

letterI :: Char -> Int
letterI c = fromMaybe (error ("Did not find '" ++ c : "' in the font")) $ findIndex (==ord c) lettersC

letterW :: Char -> Int
letterW c = lettersW !! letterI c

-- String manipulation

splitIntoLines :: String -> String
splitIntoLines s = if length s < 150 then s else (let
    correctEscapes :: (String, String) -> (String, String)
    correctEscapes (a,b)
      | last a == '\\' = correctEscapes (init a, '\\':b)
      | otherwise = (a,b)
    (a, b) = correctEscapes $ splitAt 150 s
  in a ++ "\" ++\n  \"" ++ (splitIntoLines b))

escape :: String -> String
escape = concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else if c == '\n' then "\\n" else [c])

-- Helper functions

decodeBaseBE :: (Integral a, Integral b) => b -> [a] -> b
decodeBaseBE b = let
    aux r [] = r
    aux r (d:ds) = aux (r * b + fromIntegral d) ds
 in aux 0

indexOf :: Eq a => [a] -> [a] -> Maybe Int
indexOf a [] = Nothing
indexOf a (b:bs) = if isPrefixOf a (b:bs) then Just 0 else maybe Nothing (Just . (+1)) (indexOf a bs)

align :: Integral a => a -> b -> [b] -> [b]
align a d = let
    aux i as
      | a == i = aux 0 as
      | null as = if i == 0 then [] else d : aux (i+1) []
      | otherwise = let (f:t) = as in f : aux (i+1) t
  in aux 0

chunk :: Integral a => a -> [b] -> [[b]]
chunk _ [] = []
chunk c as = let
    aux i as
      | c == i = if null as then [[]] else ([] : aux 0 as)
      | null as = [[]]
      | otherwise = let (f:t) = as; (r:rs) = aux (i+1) t in (f:r):rs
  in aux 0 as

firstPrefixOfNotFollowedBy :: Eq a => [[a]] -> [a] -> [a] -> Maybe [a]
firstPrefixOfNotFollowedBy [] _ _ = Nothing
firstPrefixOfNotFollowedBy (b:bs) n as = if isPrefixOf b as && not (elem (head (drop (length b) as)) n) then Just b else firstPrefixOfNotFollowedBy bs n as

-- Constants

lettersH = 8
lettersC = [32, 97, 65, 98, 66, 99, 67, 100, 68, 101, 69, 102, 70, 103, 71, 104, 72, 105, 73, 106, 74, 107, 75, 108, 76, 109, 77, 110, 78, 111, 79, 112, 80,
  113, 81, 114, 82, 115, 83, 116, 84, 117, 85, 118, 86, 119, 87, 120, 88, 121, 89, 122, 90, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 33, 63, 44, 46, 59, 58, 39,
  34, 47, 124, 92, 95, 40, 41, 91, 93, 123, 125, 60, 62, 64, 35, 36, 38, 43, 45, 42, 61, 94, 176, 37, 167]
lettersW = [3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 1, 3, 2, 3, 3, 3, 2, 3, 5, 5, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 5, 5, 3, 3,
  3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 1, 3, 1, 1, 1, 1, 1, 3, 3, 1, 3, 3, 2, 2, 2, 2, 3, 3, 3, 3, 5, 5, 3, 5, 3, 3, 3, 3, 3, 3, 3, 3]
lettersB = [0, 253208, 187374, 252761, 252907, 234096, 234062, 252788, 121707, 204656, 234191, 77460, 37582, 7592816, 252494, 187225, 187373, 61, 238743,
  27298, 117031, 186185, 187117, 2389, 234057, 727373152, 593155759, 187224, 187243, 121712, 121710, 2481016, 37615, 9689968, 1170286, 37488, 187119, 118384,
  117198, 75218, 74903, 252776, 252781, 88936, 88941, 358274592, 358274737, 185704, 185517, 7560040, 75117, 234808, 234663, 121710, 238746, 234787, 116963,
  149933, 116943, 219854, 75047, 121518, 118123, 47, 66851, 96, 32, 100, 36, 3, 45, 38052, 63, 148617, 229376, 9558, 6825, 13655, 15019, 1122964, 338065,
  139936, 43144, 1008654126, 368389098, 642674, 748325026, 11904, 3584, 21824, 29120, 336, 170, 136456, 949198]

programSourcePre =
  "module Exercise_13 where\n\nimport Data.Bool (bool)\nimport Data.Maybe (fromMaybe)\nimport Data.List (stripPrefix, isPrefixOf, findIndex, genericIndex" ++
  ")\nimport Data.Char (ord)\nimport Data.Word (Word8)\nimport qualified Data.ByteString as B\nimport Transform\n\nanimate :: [(String, Transform -> Tran" ++
  "sform)] -> String -> [String] \nanimate a s = map svg $ scanl (flip applyAnim) (parseInput s) $ map (:[]) a\n\npaint :: String -> String\npaint = svg " ++
  ". parseInput\n\n\n-----\n-- Animating drawings\n\n-- At first, I misinterpreted the assignment: I thought the first argument to animate were\n-- a map" ++
  " from id to transform function; and animate should produce an infinite list,\n-- where each element is another step of applying all animator functions" ++
  " to the drawing.\n-- But for an idea I have for the Wettbewerb, this behaviour is rather useful.\n-- This is why the following code is written the way" ++
  " it is.\n\napplyAnim :: [(String, Transform -> Transform)] -> Drawing -> Drawing\napplyAnim a (Drawing gs) = Drawing $ map (applyAnimGroup a) gs\n\nap" ++
  "plyAnimGroup :: [(String, Transform -> Transform)] -> Group -> Group\napplyAnimGroup a (Group shapes id tr) = Group (map (applyAnimShape a) shapes) id" ++
  " $ applyAnimTransform id a tr\n\napplyAnimShape :: [(String, Transform -> Transform)] -> Shape -> Shape\napplyAnimShape a (Shape t d1 d2 id tr) = Shap" ++
  "e t d1 d2 id $ applyAnimTransform id a tr\n\napplyAnimTransform :: String -> [(String, Transform -> Transform)] -> Transform -> Transform\napplyAnimTr" ++
  "ansform i = fromMaybe id . lookup i\n\n\n-----\n-- Input parsing\n\nparseInput :: String -> Drawing\nparseInput s = Drawing $ parseGroups (lines s) []" ++
  "\n\n-- First argument: remaining lines.\n-- Second argument: parsed groups so far, in reverse order. (head is the \"active\" group)\n-- Result: The pa" ++
  "rsed groups, in correct order.\nparseGroups :: [String] -> [Group] -> [Group]\nparseGroups [] gs = reverse gs\nparseGroups (l:ls) gs = case parseGroup" ++
  " l of\n  Just gid -> parseGroups ls $ (Group [] gid defaultTransform):gs\n  Nothing -> case gs of\n    [] -> error \"First input line has to be a grou" ++
  "p line\"\n    ((Group shapes gid tr):gs) -> case parseShape $ words l of\n      Nothing -> error $ \"Illegal line: \\\"\" ++ l ++ \"\\\"\"\n      Just" ++
  " s -> parseGroups ls $ (Group (s:shapes) gid tr):gs\n\nparseGroup :: String -> Maybe String\nparseGroup l = maybe Nothing (\\g -> if g == [] then Noth" ++
  "ing else if last g == ':' then Just $ init g else Nothing) $ stripPrefix \"group \" l\n\nparseShape :: [String] -> Maybe Shape\nparseShape ([\"rectang" ++
  "le\",id,ws,hs]) = Just $ Shape Rectangle (read ws) (read hs) id defaultTransform\nparseShape ([\"ellipse\",id,rxs,rys]) = Just $ Shape Ellipse (read r" ++
  "xs) (read rys) id defaultTransform\nparseShape _ = Nothing\n\n\n-----\n-- SVG representation and serializing\n\n-- I wanted to keep a more \"human-rea" ++
  "dable\" Show instance for my data types than their SVG representation\nclass SVG a where\n  svg :: a -> String\n\ninstance SVG Transform where\n  svg " ++
  "Transform {rotate=rotate, scale=(sx,sy), translate=(tx,ty)} = \"rotate(\" ++ (show rotate) ++\n    \") scale(\" ++ (show $ sx) ++ \" \" ++ (show $ sy)" ++
  " ++ \") translate(\" ++ (show tx) ++ \" \" ++ (show ty) ++ \")\"\n\ndata ShapeType = Rectangle | Ellipse\n  deriving (Eq, Show)\n\n-- TODO much duplic" ++
  "ation ahead...\n\ndata Shape = Shape ShapeType Double Double String Transform \n  deriving (Eq, Show)\ninstance SVG Shape where\n  svg (Shape Rectangl" ++
  "e w h ident transform) =\n    \"<rect\" ++\n    \" id=\\\"\"         ++ ident           ++ \"\\\"\" ++\n    \" width=\\\"\"      ++ (show w)        ++" ++
  " \"\\\"\" ++\n    \" height=\\\"\"     ++ (show h)        ++ \"\\\"\" ++\n    \" transform =\\\"\" ++ (svg transform) ++ \"\\\"\" ++\n    \" />\"\n  s" ++
  "vg (Shape Ellipse rx ry ident transform) =\n    \"<ellipse\" ++\n    \" id=\\\"\"         ++ ident           ++ \"\\\"\" ++\n    \" rx=\\\"\"         " ++
  "++ (show rx)       ++ \"\\\"\" ++\n    \" ry=\\\"\"         ++ (show ry)       ++ \"\\\"\" ++\n    \" transform =\\\"\" ++ (svg transform) ++ \"\\\"\"" ++
  " ++\n    \" />\"\n\ndata Group = Group [Shape] String Transform\n  deriving (Eq, Show)\ninstance SVG Group where\n  svg (Group shapes ident transform)" ++
  " =\n    \"<g\" ++\n    \" id=\\\"\"         ++ ident           ++ \"\\\"\" ++\n    \" transform =\\\"\" ++ (svg transform) ++ \"\\\"\" ++\n    \">\" +" ++
  "+ (concatMap svg shapes) ++ \"</g>\"\n\nnewtype Drawing = Drawing [Group]\ninstance SVG Drawing where\n  svg (Drawing groups) =\n    \"<svg xmlns=\\\"" ++
  "http://www.w3.org/2000/svg\\\">\" ++\n    concatMap svg groups ++\n    \"</svg>\"\nsvgWithViewBox x y w h (Drawing groups) =\n  \"<svg viewBox=\\\"\" " ++
  "++ (show x) ++ \" \" ++ (show y) ++ \" \" ++ (show w) ++ \" \" ++ (show h) ++ \"\\\" xmlns=\\\"http://www.w3.org/2000/svg\\\">\" ++\n  concatMap svg g" ++
  "roups ++\n  \"</svg>\"\n\n\n-----\n-- My Wettbewerb submission\n\n{-WETT-}\n-- Using m3x6 by Daniel Linssen (https://managore.itch.io/m3x6)\n\n-- To r" ++
  "un:\n-- Just call main. A BMP file called \"out.bmp\" will be created.\n-- Try to guess what this file contains before opening it :)\n-- Note that the" ++
  " program does not use IO operations (except of course in main for writing the output file)\n\nmain :: IO ()\nmain = B.writeFile \"out.bmp\" submission" ++
  "BMP\n\nsubmissionBMP = toBMP [(255,255,255), (0,0,0), (127,127,127), (0,200,0), (0,0,255), (255,127,0), (255,0,255), (0,200,255), (127,0,127)] $ textT" ++
  "oField (syntaxHighlight programSource) programSource\n\nprogramSource = (take markerIndex programSourcePre) ++ (splitIntoLines $ escape programSourceP" ++
  "re) ++ (drop (markerIndex + 6) programSourcePre)\n\nmarkerIndex = fromMaybe (error \"Marker not found\") $ indexOf (\"MAR\"++\"KER\") programSourcePre" ++
  "\n\n-- Synatx highlighting\n\n-- Generates a list of colors for each char, compatible with textToField\n-- 1: default\n-- 2: comments\n-- 3: strings a" ++
  "nd chars\n-- 4: ints\n-- 5: identifiers of functions / constants\n-- 6: identifiers of classes / types / constructors / constraints\n-- 7: keywords\n-" ++
  "- 8: built-ins\nsyntaxHighlight :: String -> [Integer]\nsyntaxHighlight = let\n    digits  = \"0123456789\"\n    hexDgt  = \"0123456789abcdefABCDEF\"" ++
  "\n    id1St   = \"abcdefghijklmnopqrstuvwxyz\"\n    id2St   = \"ABCDEFGHIJKLMNOPQRSTUVWXYZ\"\n    idPart  = \"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMN" ++
  "OPQRSTUVWXYZ0123456789_\"\n    kwords  = [\"module\", \"where\", \"import\", \"qualified\", \"let\", \"in\", \"instance\", \"if\", \"then\", \"else\"," ++
  " \"case\", \"of\", \"deriving\", \"data\", \"newtype\", \"type\"]\n    builtin = [\"bool\", \"fromMaybe\", \"stripPrefix\", \"isPrefixOf\", \"findInde" ++
  "x\", \"genericIndex\", \"ord\", \"map\", \"scanl\", \"flip\", \"lookup\", \"lines\", \"reverse\",\n      \"words\", \"error\", \"maybe\", \"last\", \"" ++
  "init\", \"stripPrefix\", \"read\", \"show\", \"concatMap\", \"writeFile\", \"take\", \"drop\", \"length\", \"splitAt\", \"otherwise\",\n      \"replic" ++
  "ate\", \"maximum\", \"null\", \"fromIntegral\", \"head\", \"concat\", \"div\", \"pack\", \"divMod\"]\n    -- TODO make the following code shorter\n   " ++
  " -- States:\n    -- 0: default\n    -- 1: in line comment\n    -- 2: in multiline comment\n    -- 3: in a string\n    -- 4: in a string; next char esc" ++
  "aped\n    -- 5: in a char\n    -- 6: in a char; next char escaped\n    -- 7: in an identifier of functions / constants\n    -- 8: in an identifier of " ++
  "classes / types / constructors / constraints\n    -- 9: in a hex number\n    aux :: Integer -> String -> [Integer]\n    aux _ \"\" = []\n    aux 0 ('-" ++
  "':'-':s) = 2:2 : aux 1 s\n    aux 0 ('{':'-':s) = 2:2 : aux 2 s\n    aux 0 ('\"'    :s) = 3   : aux 3 s\n    aux 0 ('\\''   :s) = 3   : aux 5 s\n    a" ++
  "ux 0 ('0':'x':s) = 4:4 : aux 9 s\n    aux 0 ('a':'s':' ':'B':'\\n':s) = 7:7:1:6:1:aux 0 s\n    aux 0 f@(c    :s) = case firstPrefixOfNotFollowedBy kwo" ++
  "rds  idPart f of\n      Just p         -> (replicate (length p) 7) ++ (aux 0 (drop (length p) f))\n      Nothing        -> case firstPrefixOfNotFollow" ++
  "edBy builtin idPart f of\n        Just p         -> (replicate (length p) 8) ++ (aux 0 (drop (length p) f))\n        Nothing        ->\n          if e" ++
  "lem c digits then 4   : aux 0 s else\n          if elem c id1St  then 5   : aux 7 s else\n          if elem c id2St  then 6   : aux 8 s else 1   : aux" ++
  " 0 s\n    aux 1 ('\\n'   :s) = 2   : aux 0 s\n    aux 1 (c      :s) = 2   : aux 1 s\n    aux 2 ('-':'}':s) = 2:2 : aux 0 s\n    aux 2 (c      :s) = 2 " ++
  "  : aux 2 s\n    aux 3 ('\"'    :s) = 3   : aux 0 s\n    aux 3 ('\\\\'   :s) = 3   : aux 4 s\n    aux 3 (c      :s) = 3   : aux 3 s\n    aux 4 (c     " ++
  " :s) = 3   : aux 3 s\n    aux 5 ('\\''   :s) = 3   : aux 0 s\n    aux 5 ('\\\\'   :s) = 3   : aux 6 s\n    aux 5 (c      :s) = 3   : aux 5 s\n    aux " ++
  "6 (c      :s) = 3   : aux 5 s\n    aux 7 f@(c    :s)\n      | elem c idPart = 5   : aux 7 s\n      | otherwise     =       aux 0 f\n    aux 8 f@(c    " ++
  ":s)\n      | elem c idPart = 6   : aux 8 s\n      | otherwise     =       aux 0 f\n    aux 9 f@(c    :s)\n      | elem c hexDgt = 4   : aux 9 s\n     " ++
  " | otherwise     =       aux 0 f\n  in aux 0\n\n-- BMP files\n\n-- color = (red, greeen, blue) (no alpha)\ntype Color = (Word8, Word8, Word8)\ntype Pa" ++
  "lette = [Color]\n-- image = [rows]; row = [0-based palette index]\ntype Image = [[Integer]]\n\ntoBMP :: Palette -> Image -> B.ByteString\ntoBMP pal im" ++
  "g = let\n    height = length img\n    width = if height == 0 then 0 else length (head img)\n    paletteEntries = length pal\n    bitsPerPixel\n      |" ++
  " paletteEntries <=   2 =  1 \n      | paletteEntries <=  16 =  4 \n      | paletteEntries <= 256 =  8\n      | otherwise             = 24\n    palette" ++
  "Length\n     | bitsPerPixel ==  1 =   2 * 3\n     | bitsPerPixel ==  4 =  16 * 3\n     | bitsPerPixel ==  8 = 256 * 3\n     | bitsPerPixel == 24 = 0\n" ++
  "    paletteData = if bitsPerPixel == 24 then [] else align paletteLength 0 (concatMap (\\(r,g,b) -> [b,g,r]) pal)\n    scanlineMapF row\n      | bitsP" ++
  "erPixel ==  1 = map (decodeBaseBE  2) $ chunk 8 $ align 8 0 row\n      | bitsPerPixel ==  4 = map (decodeBaseBE 16) $ chunk 2 $ align 2 0 row\n      |" ++
  " bitsPerPixel ==  8 = map fromIntegral row\n      | bitsPerPixel == 24 = concatMap (\\(r,g,b) -> [b,g,r]) $ map (genericIndex pal) row\n    scanlinesD" ++
  "ataUnaligned = map scanlineMapF $ reverse img\n    bitmapData = concat $ map (align 4 0) scanlinesDataUnaligned\n    bitmapOffset = 26 + paletteLength" ++
  "\n    totalSize = bitmapOffset + (div ((div (bitsPerPixel * width * height + 7) 8) + 3) 4) * 4\n  in B.pack $ concat [\n    -- BMP 2 header\n    wordL" ++
  "E 0x4D42, dwordLE totalSize, wordLE 0, wordLE 0, dwordLE bitmapOffset,\n    -- Bitmap header\n    dwordLE 12, wordLE width, wordLE height, wordLE 1, w" ++
  "ordLE bitsPerPixel,\n    -- palette data (if any)\n    paletteData,\n    -- bitmap data\n    bitmapData]\n\nwordLE = nBytesLE 2\ndwordLE = nBytesLE 4" ++
  "\n\nnBytesLE :: Integral a => a -> a -> [Word8]\nnBytesLE bits = let\n    aux 0 _ = []\n    aux b i = (fromIntegral i) : (aux (b-1) (div i 256))\n  in" ++
  " aux bits\n\n-- Font helper\n\n-- [colors for each char] -> string to render -> field of colors, 0 for background\ntextToField :: [Integer] -> String " ++
  "-> [[Integer]]\ntextToField c s = let\n    zipFirstNWith :: (a -> b -> b) -> [a] -> [b] -> [b]\n    zipFirstNWith f = let\n        aux [] bs = bs\n   " ++
  "     aux (a:as) (b:bs) = (f a b) : (aux as bs)\n      in aux\n    prependText :: [Integer] -> String -> [[Integer]] -> [[Integer]]\n    prependText _ " ++
  "\"\" r = r\n    prependText (  _:cols) ('\\n':t) r = prependText cols t $ [0] : (replicate lettersH [0]) ++ r\n    prependText (col:cols) (c   :t) r =" ++
  " prependText cols t $ zipFirstNWith (:) (replicate lettersH 0) $ zipFirstNWith (++) (map (map $ bool 0 col) $ decodeLetter c) r\n    fieldUnaligned = " ++
  "[0] : (prependText (reverse c) (reverse s) $ replicate (lettersH+1) [0])\n    width = maximum $ map length fieldUnaligned\n  in map (align width 0) fi" ++
  "eldUnaligned\n\ndecodeLetter :: Char -> [[Bool]]\ndecodeLetter c = let\n    decodeLetterAux :: Int -> Int -> Int -> [[Bool]]\n    decodeLetterAux x y " ++
  "b = let\n        (d,r) = divMod b 2\n        (s:t) = if x /= (letterW c) - 1 then decodeLetterAux (x+1) y d else if y /= lettersH - 1 then []:(decodeL" ++
  "etterAux 0 (y+1) d) else [[]]\n      in ((r /= 0):s):t\n  in decodeLetterAux 0 0 $ lettersB !! letterI c\n\nletterI :: Char -> Int\nletterI c = fromMa" ++
  "ybe (error (\"Did not find '\" ++ c : \"' in the font\")) $ findIndex (==ord c) lettersC\n\nletterW :: Char -> Int\nletterW c = lettersW !! letterI c" ++
  "\n\n-- String manipulation\n\nsplitIntoLines :: String -> String\nsplitIntoLines s = if length s < 150 then s else (let\n    correctEscapes :: (String" ++
  ", String) -> (String, String)\n    correctEscapes (a,b)\n      | last a == '\\\\' = correctEscapes (init a, '\\\\':b)\n      | otherwise = (a,b)\n    " ++
  "(a, b) = correctEscapes $ splitAt 150 s\n  in a ++ \"\\\" ++\\n  \\\"\" ++ (splitIntoLines b))\n\nescape :: String -> String\nescape = concatMap (\\c " ++
  "-> if c == '\\\\' then \"\\\\\\\\\" else if c == '\"' then \"\\\\\\\"\" else if c == '\\n' then \"\\\\n\" else [c])\n\n-- Helper functions\n\ndecodeBa" ++
  "seBE :: (Integral a, Integral b) => b -> [a] -> b\ndecodeBaseBE b = let\n    aux r [] = r\n    aux r (d:ds) = aux (r * b + fromIntegral d) ds\n in aux" ++
  " 0\n\nindexOf :: Eq a => [a] -> [a] -> Maybe Int\nindexOf a [] = Nothing\nindexOf a (b:bs) = if isPrefixOf a (b:bs) then Just 0 else maybe Nothing (Ju" ++
  "st . (+1)) (indexOf a bs)\n\nalign :: Integral a => a -> b -> [b] -> [b]\nalign a d = let\n    aux i as\n      | a == i = aux 0 as\n      | null as = " ++
  "if i == 0 then [] else d : aux (i+1) []\n      | otherwise = let (f:t) = as in f : aux (i+1) t\n  in aux 0\n\nchunk :: Integral a => a -> [b] -> [[b]]" ++
  "\nchunk _ [] = []\nchunk c as = let\n    aux i as\n      | c == i = if null as then [[]] else ([] : aux 0 as)\n      | null as = [[]]\n      | otherwi" ++
  "se = let (f:t) = as; (r:rs) = aux (i+1) t in (f:r):rs\n  in aux 0 as\n\nfirstPrefixOfNotFollowedBy :: Eq a => [[a]] -> [a] -> [a] -> Maybe [a]\nfirstP" ++
  "refixOfNotFollowedBy [] _ _ = Nothing\nfirstPrefixOfNotFollowedBy (b:bs) n as = if isPrefixOf b as && not (elem (head (drop (length b) as)) n) then Ju" ++
  "st b else firstPrefixOfNotFollowedBy bs n as\n\n-- Constants\n\nlettersH = 8\nlettersC = [32, 97, 65, 98, 66, 99, 67, 100, 68, 101, 69, 102, 70, 103, " ++
  "71, 104, 72, 105, 73, 106, 74, 107, 75, 108, 76, 109, 77, 110, 78, 111, 79, 112, 80,\n  113, 81, 114, 82, 115, 83, 116, 84, 117, 85, 118, 86, 119, 87," ++
  " 120, 88, 121, 89, 122, 90, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 33, 63, 44, 46, 59, 58, 39,\n  34, 47, 124, 92, 95, 40, 41, 91, 93, 123, 125, 60, " ++
  "62, 64, 35, 36, 38, 43, 45, 42, 61, 94, 176, 37, 167]\nlettersW = [3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 1, 3, 2, 3, 3, 3, 2, 3, 5, 5, 3," ++
  " 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 5, 5, 3, 3,\n  3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 1, 3, 1, 1, 1, 1, 1, 3, 3, 1, 3, 3, 2, 2," ++
  " 2, 2, 3, 3, 3, 3, 5, 5, 3, 5, 3, 3, 3, 3, 3, 3, 3, 3]\nlettersB = [0, 253208, 187374, 252761, 252907, 234096, 234062, 252788, 121707, 204656, 234191," ++
  " 77460, 37582, 7592816, 252494, 187225, 187373, 61, 238743,\n  27298, 117031, 186185, 187117, 2389, 234057, 727373152, 593155759, 187224, 187243, 1217" ++
  "12, 121710, 2481016, 37615, 9689968, 1170286, 37488, 187119, 118384,\n  117198, 75218, 74903, 252776, 252781, 88936, 88941, 358274592, 358274737, 1857" ++
  "04, 185517, 7560040, 75117, 234808, 234663, 121710, 238746, 234787, 116963,\n  149933, 116943, 219854, 75047, 121518, 118123, 47, 66851, 96, 32, 100, " ++
  "36, 3, 45, 38052, 63, 148617, 229376, 9558, 6825, 13655, 15019, 1122964, 338065,\n  139936, 43144, 1008654126, 368389098, 642674, 748325026, 11904, 35" ++
  "84, 21824, 29120, 336, 170, 136456, 949198]\n\nprogramSourcePre =\n  \"MARKER\"\n\n{-TTEW-}\n"

{-TTEW-}