-- /etc/shadow --
-- Standardfunktionen importieren
import Char  (toUpper, toLower)
import Maybe (fromMaybe)
import List  (sortBy)
import IO

-- ------------------------ helper functions
-- alle Berechnung auf dem folgenden Alphabet
alphabet = ['A'..'Z'] :: String

-- relative Buchstabenhäufigkeit im Deutschen (bei Wikipedia gefunden)
deutsch = [('E', 0.1740),
           ('N', 0.0978),
           ('I', 0.0755),
           ('S', 0.0727),
           ('R', 0.0700),
           ('A', 0.0651),
           ('T', 0.0615),
           ('D', 0.0508),
           ('H', 0.0476),
           ('U', 0.0435),
           ('L', 0.0344),
           ('C', 0.0306),
           ('G', 0.0301),
           ('M', 0.0253),
           ('O', 0.0251),
           ('B', 0.0189),
           ('W', 0.0189),
           ('F', 0.0166),
           ('K', 0.0121),
           ('Z', 0.0113),
           ('P', 0.0079),
           ('V', 0.0067),
           ('J', 0.0027),
           ('Y', 0.0004),
           ('X', 0.0003),
           ('Q', 0.0002)] :: [(Char, Double)]

-- angepasste Version von isAlpha, die testet, ob ein Buchstabe in unserem Alphabet vorhanden ist
-- klein geschriebene Buchstaben sind auch akzeptabel
isAlpha' = flip elem $ alphabet ++ (map toLower alphabet)

-- entfernt alle komischen Zeichen aus einem String und wandelt den Rest in Grossbuchstaben um
prune = map toUpper . filter isAlpha'

-- sortiert eine Liste aufsteigend entsprechend der Funktionswerte von Funktion f
fsort  f = List.sortBy (\x y -> compare (f x) (f y))
-- macht das gleiche wie fsort, nur in absteigender Reihenfolge
fsort' f = reverse . fsort f

-- summiert die Funktionswerte von der Funktion f auf
fsum f = sum . (map f)

-- dividiert zwei Ganzzahlen
divide x y = fromIntegral x / fromIntegral y

-- ------------------------ text analysis
count :: String -> [(Char, Int)]
-- zählt, wie oft die Buchstaben in einem String vorkommen
count s = zip alphabet $ map (\x -> length $ filter (==x) s) alphabet

normalize :: [(Char, Int)] -> [(Char, Double)]
-- wandelt eine von count erstellte Liste in relative Werte um
normalize s = map (flip normalize' counter) s
                    where counter = fsum snd s

normalize' :: (Char, Int) -> Int -> (Char, Double)
-- normalisiert einen einzelnen Eintrag aus einer von count erstellten Liste
normalize' (s,i) n = (s, divide i n)

-- ------------------------ caesar
caesarEncode :: Char -> String -> String
-- verschlüsselt einen Text nach der Caesar-Methode
caesarEncode x y = substitute (prune y) (getCaesar x)
-- weil man es immer wieder mal braucht: mit verdrehten Argumenten
caesarEncode' = flip caesarEncode

substitute :: String -> [(Char, Char)] -> String
-- hat eine Liste von Ersetungen und führt sie auf einem String aus
substitute x y = map (\x -> fromMaybe x (lookup x y))  x

getCaesar :: Char -> [(Char, Char)]
-- erstellt die Liste der Caesar-Ersetzungen für eine gegebene Verschiebung
getCaesar x = zip alphabet $ dropWhile (/=x) $ cycle alphabet

-- ------------------------ vigenere
vigenere :: String -> String -> String
-- verschlüsselt einen Text nach der Vigenere-Methode. k wie key und d wie data...
vigenere k = zipWith (\k d -> head $ substitute [d] (getCaesar k)) (cycle k)

-- sichere Version von vigenere
vigenereEncode k d = vigenere (prune k) (prune d)
-- und auch hier nochmal geflipt
vigenereEncode'    = flip vigenereEncode

-- entschlüsseln eines mit vigenere verschlüsselten Text bei bekannter Passphrase
vigenereDecode k = vigenereEncode $ invertKey $ prune k
-- und wieder geflipt
vigenereDecode'  = flip vigenereDecode

-- Vigenere-Schlüssel invertieren
invertKey :: String -> String
invertKey = map (\x -> fromMaybe x $ lookup x $ zip y $ reverse y)
            where y = alphabet ++ [head alphabet]

-- ------------------------ übungsblatt
korrelationsfunktion :: String -> String -> Integer
-- Korrelation berechnen. an wievielen Stellen sind beide Strings gleich.
-- nein, das kann man nicht anders machen ;)
korrelationsfunktion = curry $ foldl (\s (x,y) -> if x == y then succ s else s) 0 . uncurry zip

zyklischeverschiebungen :: String -> [String]
-- alle zyklischen Verschiebungen eines Textes
-- die Mengenschreibweise ist zwar normal nicht mein Fall, aber hier ist sie sehr schnell (Ausführungsgeschwindigkeit)
zyklischeverschiebungen s = [(drop n s) ++ (take n s) | n <- [0..pred $ length s]] -- (so ähnlich im Forum gefunden ;))

autokorrelation :: String -> [(Integer, Integer)]
-- Autokorrelation eines Textes mit sich selbst. einfach gegen alle zyklischen Verschiebungen testen
autokorrelation x = zip [0..] $ map (korrelationsfunktion x) (zyklischeverschiebungen x)

-- ------------------------ entschlüsseln
passphraselength :: String -> [(Integer, Integer)]
-- Passphrase-Länge knacken. erst einmal die 25 Verschiebungen mit der besten Korrelation finden
passphraselength = fsort fst . take 25 . fsort' snd . autokorrelation

divCount :: [Integer] -> Integer -> Integer
-- Anzahl der Zahlen aus der Liste, die sich durch die Zahl teilen lassen
divCount x y = foldl (\s x -> if mod x y == 0 then succ s else s) 0 x 

goodDivisors :: [Integer] -> [Integer] -> [Integer]
-- die drei Zahlen aus der zweiten Liste, die die meisten Zahlen aus der ersten Liste teilen
goodDivisors x y = map fst $ take 3 $ fsort' snd $ zip y $ map (divCount x) y

-- above: PW length; below: PW text

split :: [a] -> Int -> [[a]]
-- in unserem Fall: die Buchstaben, die mit dem gleichen Caesar-Schlüssel verschlüsselt wurden zusammenpacken
-- kann man aber bestimmt auch noch andere tolle Dinge mit machen
split x n = foldl (\x (a,b) -> insert a b x) (replicate n []) indexed
            where indexed = zip x $ cycle [0..(n-1)]

insert :: a -> Int -> [[a]] -> [[a]]
-- für die split/insert-Aktion fiel mir nichts einfaches mit Higher-Level-Funktionen ein.
-- jedes Element wird in die vorgesehen Liste einsortiert
insert x 0 (a:b) = (x:a) : b
insert x n (a:b) = a : (insert x (n-1) b)

rateDecrypts :: String -> [(Char, Double)]
-- für einen String bewerten, wie "deutsch" eine Verschiebung ist
-- niedrieger Wert bedeutet, dass die Caesar-Verschlüsselung mit dieser Verschiebung einen besonders deutschen Text liefert
rateDecrypts str = zip (invertKey alphabet) (map undeutschness decs)
                   where decs = map (caesarEncode' str) alphabet

undeutschness :: String -> Double
-- checken, wie undeutsch ein Text ist
undeutschness = (unlikelihood deutsch) . normalize . count                   
   
unlikelihood :: [(Char, Double)] -> [(Char, Double)]  -> Double
-- checken, wie unterschiedlich zwei Buchstabenverteilungen sind
-- sehr ähnliche Verteilungen erzeugen KLEINE werte
unlikelihood d = fsum (\x -> (snd x - find (fst x) d) ^ 4 * 10000)

find :: Char -> [(Char, Double)] -> Double
-- relative Häufigkeit eines Buchstabens aus einer Verteilung heraussuchen
find = curry $ fromMaybe 0 . uncurry lookup

suggestKey :: [[(Char, Double)]] -> String
-- einen genauen Schlüssel vorschlagen (einfach immer den Buchstaben nehmen, der die niedrigste undeutschness hat)
suggestKey = map $ fst . head
-- ------------------------ program
-- Zahl einlesen (irgendwo im Netz gefunden)
readNumber = do line <- getLine
                readIO line

-- Hauptfunktion: erstmal einen Dateinamen erfragen und dann versuchen, sie zu knacken
main = do putStr "Please enter File to analyze:\n"
          filename <- getLine
          catch (
                 do inHandle <- openFile filename ReadMode
                    content' <- hGetContents inHandle
                   
                    let content = prune content' -- Datei einlesen und den String ggf. aufräumen
                    let len = passphraselength content -- die Passphrase-Länge errechen
                   
                    putStr "Processing... ... ... (may take a while, seriously doing sth now)\n"
                    putStr $ show len
                    putStr "\nPassphrase Length Cruncher thus suggests a Passphrase Length of:\n"
                    putStr $ show $ goodDivisors (drop 1 $ map fst len) [2..25]
                    putStr "\nPlease enter Passphrase Length:\n"
                    a <- readNumber
                   
                    let ana = map (take 5 . fsort snd . rateDecrypts) $ split content a -- Caesar-Brute-Force-Entschlüssöung auf die Sache ansetzen
                   
                    putStr "Processing... ... ... (may take a while, seriously doing sth now)\n"
                    putStr $ unlines $ map show ana
                    putStr "\nPassphrase Cruncher thus suggests a Passphrase of:\n"
                    putStr $ suggestKey ana
                    putStr "\nPlease enter Passphrase:\n"
                    key <- getLine
                    putStr $ vigenereDecode key content -- und zum Schluss noch einmal entschlüsseln
                    putStr "\nPress enter to exit:"
                    wait <- getLine
                   
                    hClose inHandle
                )
                (\_ -> putStr "ERROR: does not compute!" ) -- Fehler: bla
          putStr "\n"