ieee-helper.hs

import Data.List (findIndex)
import Data.Maybe
import Data.Char
import Text.Read
import System.Environment

type Vorkomma = [Bool]
type Nachkomma = [Bool]
type BinaryZahl = [Bool]
type Exponent = [Bool]
type Charakteristik = [Bool]
data IEEE = ISingle | IDouble

version = "v1.1"


bin2nachkomma :: Nachkomma -> Double
bin2nachkomma =
    foldl (\acc (i,cur) -> if cur then acc + 1/(2^i) else acc ) 0.0
    . (zip [1..])

bin2vorkomma :: Vorkomma -> Double
bin2vorkomma =
    foldl (\acc (i,cur) -> if cur then acc + 2^i else acc ) 0.0
    . (zip [0..])
    . reverse


vorkomma2bin :: Int -> Vorkomma
vorkomma2bin i = conv i []
    where
        conv :: Int -> [Bool] -> Vorkomma
        conv 0 l = l
        conv f l =
            let
                rest = f `mod` 2
                zahl = floor $ (fromIntegral f) / 2
                b = if rest == 0 then False else True
            in
            conv zahl $ b : l


-- Achtung: Unendliche Liste!
nachkomma2bin :: Double -> Nachkomma
nachkomma2bin 0 = repeat False
nachkomma2bin 0.5 = True : repeat False
nachkomma2bin f = 
    if df > 1 then 
        True : (nachkomma2bin $ df-1)
    else 
        False : (nachkomma2bin $ df)
    where 
        df = 2*f
                

normalisierterWert :: Vorkomma -> Nachkomma -> (BinaryZahl, Int)
normalisierterWert vorkomma nachkomma =
    if length vorkomma == 1 then
        (nachkomma, 0)
    else if length vorkomma > 1 then
        ((tail vorkomma) ++ nachkomma, length vorkomma - 1 )
    else
        let
            mayIndex = findIndex (id) nachkomma
        in
        case mayIndex of
            Just index ->
                (snd (splitAt (index+1) nachkomma), (-1) - index) 
            Nothing ->
                -- Das Ding ist null!
                ([], 0)

denormalisierterWert :: (Maybe BinaryZahl, Maybe Int) -> (Maybe Vorkomma, Maybe Nachkomma)
denormalisierterWert (mbin, mexponent) =
    case (mbin,mexponent) of
        (Just bin, Just exponent) ->
            let
                (vorkomma, nachkomma) = splitFillWith (exponent+1) False (True:bin)
            in
            if (exponent > 0) && (exponent+1 > length vorkomma) then
                (Just vorkomma, Just nachkomma)
            else
                (Just vorkomma, Just nachkomma)
        _ -> (Nothing, Nothing)

-- Reverse SequenceA:  fromMaybe [] $ map (pure :: Int -> Maybe Int) <$> Just [1,0,1]

-- -------------------------------------------------------------------------------------------------------------------------
-- IO
-- -------------------------------------------------------------------------------------------------------------------------

bin2dez :: String -> Double
bin2dez l = 
    (bin2vorkomma  $ map (=='1') vorkomma)
    +
    (bin2nachkomma $ map (=='1') nachkomma)
    where
        (vorkomma, nachkomma) =
            splitOn '.' l



dez2bin :: Int -> Double -> String
dez2bin p f =
    (map boolShow $ vorkomma2bin vorkomma)
    ++ "."
    ++ (map boolShow $ take p $ nachkomma2bin nachkomma)

    where 
        vorkomma = fromIntegral $ floor f
        nachkomma = f - (fromIntegral vorkomma)
        boolShow = (\ a -> if a then '1' else '0')



construct2IEEE :: IEEE -> Double -> String
construct2IEEE ieee f = printIEEE $
    case ieee of
        ISingle ->   buildIEEE 23 8 f
        IDouble ->   buildIEEE 52 11 f
    where
        printIEEE ( vrz, char, man ) =
            boolShow [vrz] ++ char ++ man



buildIEEE :: Int -> Int -> Double -> (Bool, String, String)
buildIEEE p n f =
    (vrz
    , boolShow $ boolFillBefore n $ vorkomma2bin character 
    , boolShow $ boolFillAfter p $ take p $ mantisse)
    where
        vrz = f < 0

        character =  2^(n-1) - 1 + exponent

        (mantisse, exponent) = 
            normalisierterWert vorkomma nachkomma

        vorkomma = 
            vorkomma2bin $ fromIntegral $ floor $ abs f

        nachkomma = 
            take p $ nachkomma2bin $ (abs f) - (fromIntegral $ floor $ abs f)

   
destructIEEE :: Maybe String -> Maybe Double
destructIEEE (Just str) =
    if length str == 32 then
        destruct 8 str
    else if length str == 64 then
        destruct 11 str
    else
        Nothing

    where
        destruct :: Int -> String -> Maybe Double
        destruct n input =
            let
            vrz = if head input == '1' then (-1) else 1
            (character, mantisse) = splitAt n $ tail input
            exponent = 
                (\i -> i - (2^(n-1) - 1))
                <$> fromIntegral . floor . bin2vorkomma
                <$> parseBool character 
            (vorkomma, nachkomma) = 
                denormalisierterWert (parseBool mantisse, exponent)
            in
            (*) <$> pure vrz 
            <*> ((+)
              <$> (bin2vorkomma <$> vorkomma) 
              <*> (bin2nachkomma <$> nachkomma))
destructIEEE Nothing = Nothing
             

        
-- -------------------------------------------------------------------------------------------------------------------------
-- Main Programm
-- -------------------------------------------------------------------------------------------------------------------------

printError :: String
printError = "Invalid Arguments\nTry ieee-helper --help to get help"

printWithDefault :: String -> (String -> String) -> [String] -> String
printWithDefault def _ [] = def
printWithDefault _ f (a:_) = f a

printToIEEE :: [String] -> String
printToIEEE (mode:value_in:_) =
    let
        fp = (readMaybe value_in) :: Maybe Double
    in
    fromMaybe printError $
        printPretty <$>
            case map toLower mode of
                "single" -> construct2IEEE ISingle <$> fp
                "s"      -> construct2IEEE ISingle <$> fp
                "double" -> construct2IEEE IDouble <$> fp
                "d"      -> construct2IEEE IDouble <$> fp
                _        -> Nothing

    where
        printPretty s = unlines
            [ "After Formatting for IEEE754 your number becomes:"
            , bin2Hex s
            , "or in Binary:"
            , s
            ]
printToIEEE _ = printError

printDecToBin :: [String] -> String
printDecToBin (p:num:_) = 
    fromMaybe printError $ printPretty <$> (dez2bin <$> readMaybe p <*> readMaybe num)
    where
        printPretty :: String -> String
        printPretty v = unlines
            [ "Your Decimal number \"" ++ (show $ (read num :: Double)) ++ "\" is the following in binary:"
            , v
            , "You could also just write " ++ bin2Hex v ++ " if that is easier."
            ]
printDecToBin _ = printError

printIEEEToFp :: [String] -> String
printIEEEToFp (value_in:_) =
    let
        (hexIdent, hVal) = splitAt 2 value_in
    in
    fromMaybe "That didn't work :(" $
        printPretty <$>
            if hexIdent == "0x" then
                showPretty <$> destructIEEE (hex2Bin value_in)
            else
                showPretty <$> destructIEEE (pure value_in)
    where
        printPretty s = unlines
            [ "After reading your IEEE754 input the value is:"
            , s
            ]
        showPretty :: Double -> String
        showPretty = show
printIEEEToFp _ = printError


mainInteract :: [String] -> String
mainInteract (mode:args) =
    case mode of
        "BinToHex"  -> printWithDefault
            printError bin2Hex args

        "HexToBin"  -> printWithDefault 
            printError (fromMaybe printError . hex2Bin) args
        "DecToBin"  -> printDecToBin args
        "BinToDec"  -> printWithDefault
            printError (("Your Number is: " ++) . show . bin2dez) args

        "DecToIEEE" -> printToIEEE args
        "IEEEToDec" -> printIEEEToFp args
        "-v"        -> version
        "--version" -> version
        "-h"        -> printHelp
        "--help"    -> printHelp
        _           -> printError
mainInteract _      =  printHelp

main :: IO ()
main = do
    args <- getArgs
    putStr $ mainInteract args


printHelp :: String
printHelp = unlines
    [ "IEEE Helper Tool" ,""
    , "Usage:"
    , "  ieee-helper BinToHex <binNumber>"
    , "  ieee-helper HexToBin <hexNumber>"
    , "  ieee-helper DecToBin <precision> <decNumber>"
    , "  ieee-helper BinToDec <binNumber>"
    , "  ieee-helper DecToIEEE [(Single|s)|(Double|d)] <decNumber>"
    , "  ieee-helper IEEEToDec <ieee754BinNumber>"
    , "  ieee-helper -h | --help"
    , "  ieee-helper -v | --version"
    , ""
    , "Options:"
    , "  -h --help\t\tShow this help screen"
    , "  -v --version\t\tShow current Version"
    , ""
    , "Command Descriptions:"
    , "  BinToHex <binNumber>\t\t\t\tConvert a binary number to a hexadecimal number."
    , "  HexToBin <hexNumber>\t\t\t\tConvert a hexadecimal number to a binary number."
    , "  DecToBin <precision> <decNumber>\t\tConvert a decimal number to a binary number."
    , "  \t\t\t\t\t\t  Precision is the number of bits after the point."
    , "  BinToDec <binNumber>\t\t\t\tConvert binary floating number to decimal number."
    , "  DecToIEEE [(Single|s)|(Double|d)] <decNumber>\tConvert a decimal number to a IEEE754 compliant number."
    , "  IEEEToDec <ieee754BinNumber>\t\t\tInput a IEEE754 binary number and get the decimal representation."
    , ""
    , "Argument Descriptions:"
    , "  binaryNumber\t\tBinary number. Don't seperate by spaces. E.g. 0100101101"
    , "  hexNumber\t\tHexadecimal number. E.g. 0x42DF"
    , "  precision\t\tHow many digits after the point should be calculated? E.g. 3"
    , "  decNumber\t\tFloating point decimal number. E.g. 3.14"
    , "  ieee754BinNumber\tIEEE754 compliant bin number. E.g. 01000000010010001111010111000010"
    , ""
    , "Examples:"
    , "  ieee-helper HexToBin 0x43D.54"
    , "  ieee-helper DecToBin 23 3.1416"
    , "  ieee-helper DecToIEEE Single 42.743"
    , "  ieee-helper IEEEToDec 0x42b844dd"
    , "  ieee-helper BinToHex 110110.1011001"
    ]


-- -------------------------------------------------------------------------------------------------------------------------
-- Helpers
-- -------------------------------------------------------------------------------------------------------------------------

splitOn :: Eq e => e -> [e] -> ([e], [e])
splitOn e l =
    case t of
        [] -> (h, [])
        (x:_) -> (h, tail t)
    where
        (h, t) =
            splitAt (fromMaybe 0 (findIndex (== e) l)) l

splitFillWith :: Int -> a -> [a] -> ([a], [a])
splitFillWith index def ls =
    if index > (length ls) then
        ( ls ++ replicate (index - (length ls)) def , [] )
    else if index < 0 then
        ( [], replicate (0-index) def ++ ls )
    else
        splitAt index ls

bin2Hex :: String -> String
bin2Hex str =
    
    if '.' `elem` str then
        let
            (vorkomma, nachkomma) = splitOn '.' str
        in
        "0x" ++     doConversion vorkomma 
        ++ "." ++   doConversionR nachkomma
    else if ',' `elem` str then
        let
            (vorkomma, nachkomma) = splitOn ',' str
        in
        "0x" ++     doConversion vorkomma 
        ++ "." ++   doConversionR nachkomma
    else
        "0x" ++     doConversion str
        
    where
        doConversion  = showHex . convert . reverse  . makeInt
        doConversionR = showHex . reverse . convertR . makeInt

        makeInt = map (\c -> if c == '1' then 1 else 0)

        convert [] = []
        convert (a:b:c:d:xs) = d*8 + c*4 + b*2 + a : convert xs
        convert (a:b:c:xs) = c*4 + b*2 + a : convert xs
        convert (a:b:xs) = b*2 +a : convert xs
        convert (a:xs) = a : convert xs

        convertR [] = []
        convertR (d:c:b:a:xs) = d*8 + c*4 + b*2 + a : convertR xs
        convertR (d:c:b:xs) = d*8 + c*4 + b*2 : convertR xs
        convertR (d:c:xs) = d*8 + c*4 : convertR xs
        convertR (d:xs) = d*8 : convertR xs

showHex :: [Int] -> String
showHex [] = ""
showHex (x:xs)
    | x <= 9 = showHex xs ++ show x
    | x == 10 = showHex xs ++ "A"
    | x == 11 = showHex xs ++ "B"
    | x == 12 = showHex xs ++ "C"
    | x == 13 = showHex xs ++ "D"
    | x == 14 = showHex xs ++ "E"
    | x == 15 = showHex xs ++ "F"
    | otherwise = "0"

hex2Bin :: String -> Maybe String
hex2Bin str = 
    concat <$> 
    (sequenceA . init . convert . snd . splitAt 2 . map toUpper) str
    where
        convert [] = [Nothing]
        convert (x:xs)
            | x == '0' = Just "0000" : convert xs
            | x == '1' = Just "0001" : convert xs
            | x == '2' = Just "0010" : convert xs
            | x == '3' = Just "0011" : convert xs
            | x == '4' = Just "0100" : convert xs
            | x == '5' = Just "0101" : convert xs
            | x == '6' = Just "0110" : convert xs
            | x == '7' = Just "0111" : convert xs
            | x == '8' = Just "1000" : convert xs
            | x == '9' = Just "1001" : convert xs
            | x == 'A' = Just "1010" : convert xs
            | x == 'B' = Just "1011" : convert xs
            | x == 'C' = Just "1100" : convert xs
            | x == 'D' = Just "1101" : convert xs
            | x == 'E' = Just "1110" : convert xs
            | x == 'F' = Just "1111" : convert xs
            | otherwise = [Nothing]



boolFillBefore :: Int -> [Bool] -> [Bool]
boolFillBefore n x = 
    replicate (n - length x) False ++ x

boolFillAfter :: Int -> [Bool] -> [Bool]
boolFillAfter n x = 
    x ++ replicate (n - length x) False

boolShow :: [Bool] -> String
boolShow =
    map (\ a -> if a then '1' else '0')

parseBool :: String ->  Maybe [Bool]
parseBool = sequenceA . map toBool
    where
        toBool c =
            if c == '1' then        Just True
            else if c == '0' then   Just False
            else                    Nothing