module Sol_Exercise_12 where
import Control.Monad (liftM)
import qualified Data.ByteString as BS
import Data.Bits
import Data.Char
import Data.List (permutations, subsequences, find, sortBy)
import Data.Function (on)
import Data.Maybe (fromJust)
import Data.Word (Word8)
import qualified Huffman as H
import System.IO

{- Library -- nicht veraendern -}

data Html =
  Text String |
  Block String [Html]
  deriving Show

html_ex1 = Text "Every string should learn to swim"
html_ex2 = Block "head" []
html_ex3 = Block "body" [Block "p" [Text "My cat"], Text "is not a float"]
html_ex4 = Text "Sei Epsilon < 0"
html_ex5 = Text "Üblicherweise ist 𝜀 > 0"

data Expr = Input Integer |
            Add Expr Expr |
            Sub Expr Expr |
            Mul Expr Expr deriving Eq

instance Show Expr where
  show (Input n) = show n
  show (Add e1 e2) = "(" ++ show e1 ++ " + " ++ show e2 ++ ")"
  show (Sub e1 e2) = "(" ++ show e1 ++ " - " ++ show e2 ++ ")"
  show (Mul e1 e2) = "(" ++ show e1 ++ " * " ++ show e2 ++ ")"

foldExpr :: (Integer -> a) -> (a -> a -> a) -> (a -> a -> a) -> (a -> a -> a) -> Expr -> a
foldExpr f _ _ _ (Input n) = f n
foldExpr f g h i (Add e1 e2) = g (foldExpr f g h i e1) (foldExpr f g h i e2)
foldExpr f g h i (Sub e1 e2) = h (foldExpr f g h i e1) (foldExpr f g h i e2)
foldExpr f g h i (Mul e1 e2) = i (foldExpr f g h i e1) (foldExpr f g h i e2)


{- G11.1 -}

serializeHuff :: [H.Bit] -> BS.ByteString
serializeHuff = BS.pack . ser
  where
    ser bits = if len == 8
      then ch8 : ser bits2
      else [ch8 `shiftL` (8 - len), fromInteger $ toInteger len]
       where
        (bits1, bits2) = splitAt 8 bits
        len = length bits1 
        ch8 = toWord8 0 bits1

    toWord8 n [] = n
    toWord8 n (H.L:xs) = toWord8 (n `shiftL` 1) xs
    toWord8 n (H.R:xs) = toWord8 ((n `shiftL` 1) .|. 1) xs

deserializeHuff :: BS.ByteString -> Maybe [H.Bit]
deserializeHuff = deser . BS.unpack
  where
    deser :: [Word8] -> Maybe [H.Bit]
    deser [x,l] = Just $ take (fromInteger $ toInteger l) (fromWord8 x)
    deser (x:xs) = case deser xs of
                    Nothing -> Nothing
                    Just res -> Just $ fromWord8 x ++ res
    deser _ = Nothing

    fromWord8 c = reverse [ if testBit c n then H.R else H.L | n <- [0..7] ]

compress :: String -> FilePath -> IO ()
compress xs file = do
    BS.writeFile (file ++ ".code") (H.serializeTree tree)
    BS.writeFile (file ++ ".huff") (serializeHuff huff)
  where
    tree = H.mkTree $ H.mkFTable xs
    huff = H.encode (H.mkCTable tree) xs

decompress :: FilePath -> IO (Maybe String)
decompress file = do
    rawTree <- BS.readFile (file ++ ".code")
    rawHuff <- BS.readFile (file ++ ".huff")
    let tree = H.deserializeTree rawTree
    return $ case deserializeHuff rawHuff of
      Nothing -> Nothing
      Just huff -> Just $ H.decode tree huff

{- G11.2 -}

namedEntities :: [(Char, String)]
namedEntities =
  [('<', "lt"), ('>', "gt"), ('&',"amp"), ('ß', "szlig"),
   ('Ä', "Auml"), ('Ö', "Ouml"), ('Ü', "Uuml"),
   ('ä', "auml"), ('ö', "ouml"), ('ü', "uuml")]


htmlChar :: Char -> String
htmlChar c = case lookup c namedEntities of
    Just name -> "&" ++ name ++ ";"
    Nothing -> if n < 128 then [c] else "&#" ++ show n ++ ";"
  where n = ord c

plainHtml :: Html -> String
plainHtml (Text cs) = concatMap htmlChar cs
plainHtml (Block s hs) =
  "<" ++ s ++ ">" ++ concatMap plainHtml hs ++ "</" ++ s ++ ">"

{- H11.1 -}

table =
  [ (n, chr $ ord 'A' + n ) | n <- [0..25] ] ++
  [ (n + 26, chr $ ord 'a' + n ) | n <- [0..25] ] ++
  [ (n + 52, chr $ ord '0' + n ) | n <- [0..9] ] ++
  [ (62, '+'), (63, '/') ]

encode :: [Bool] -> [Char]
encode [] = []
encode xs = convert (toInt (reverse block)) : encode rest
  where (block, rest) = splitAt 6 xs
        convert = fromJust . flip lookup table
        toInt [] = 0
        toInt (True : xs) = 1 + 2 * toInt xs
        toInt (False : xs) = 2 * toInt xs

toBits :: [Word8] -> [Bool]
toBits = concatMap (\w -> map (testBit w) [7,6..0])

fromBytes :: [Word8] -> [Char]
fromBytes [] = []
fromBytes xs =
  case len of
    1 -> take 2 encoded ++ "=="
    2 -> take 3 encoded ++ "="
    _ -> encoded ++ fromBytes rest
  where (chunk, rest) = splitAt 3 xs
        len = length chunk
        encoded = encode $ toBits $ chunk ++ replicate (3 - len) 0

base64 :: BS.ByteString -> [Char]
base64 = fromBytes . BS.unpack

main :: IO ()
main = BS.getContents >>= putStrLn . base64

{- H11.2 -}

-- loosely based on Hutton

pick :: [a] -> [(a, [a])]
pick [] = []
pick (x : xs) = (x, xs) : [(a, x:as) | (a, as) <- pick xs]

eval :: Expr -> Integer
eval (Input n) = n
eval (Add e1 e2) = eval e1 + eval e2
eval (Sub e1 e2) = eval e1 - eval e2
eval (Mul e1 e2) = eval e1 * eval e2

splits :: [a] -> [([a], [a])]
splits [] = []
splits (x : xs) = ([], x:xs) : [(x:ys, zs) | (ys, zs) <- splits xs]

candidates :: [a] -> [[a]]
candidates = concatMap permutations . subsequences

exprs' :: [Integer] -> [Expr]
exprs' [] = []
exprs' [x] = [Input x]
exprs' xs = pickExprs
  where pickExprs = [ f e1 e2 | (ys, zs) <- splits xs
                              , e1 <- exprs' ys
                              , e2 <- exprs' zs
                              , f <- [Add, Sub, Mul] ]

exprs :: [Integer] -> [Expr]
exprs = concatMap exprs' . candidates

checkExpr :: [Integer] -> Integer -> Maybe Expr
checkExpr xs n = find ((n==) . eval) $ exprs xs

approxExpr :: [Integer] -> Integer -> Expr
approxExpr xs n = head $ sortBy (compare `on` abs . (n-) . eval) $ exprs xs