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) =
""
svg (Shape Ellipse rx ry ident transform) =
""
data Group = Group [Shape] String Transform
deriving (Eq, Show)
instance SVG Group where
svg (Group shapes ident transform) =
"" ++ (concatMap svg shapes) ++ ""
newtype Drawing = Drawing [Group]
instance SVG Drawing where
svg (Drawing groups) =
""
svgWithViewBox x y w h (Drawing groups) =
""
-----
-- 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 \"\"\n s" ++
"vg (Shape Ellipse rx ry ident transform) =\n \"\"\n\ndata Group = Group [Shape] String Transform\n deriving (Eq, Show)\ninstance SVG Group where\n svg (Group shapes ident transform)" ++
" =\n \"\" +" ++
"+ (concatMap svg shapes) ++ \"\"\n\nnewtype Drawing = Drawing [Group]\ninstance SVG Drawing where\n svg (Drawing groups) =\n \"\"\nsvgWithViewBox x y w h (Drawing groups) =\n \"\"\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-}