import Data.Text (splitOn, unpack, pack, strip)
    import Data.List(inits, tails)
    import System.Environment (getArgs)
    import Data.Set (fromList, toList)


    main = do
    lns <- getLines

    let seed = head lns
    let instructions = map (splitOnStr "->") (filter (contains "->") lns)

    args <- getArgs
    let desiredRounds = ((read::String->Int).head) (args)

    -- -- Part 1 - Naive
    -- putStrLn "Part 1"

    -- let polymer = growPolymer desiredRounds seed instructions
    -- let alphabet = fromList polymer
    -- let occurrences = map (\a->
    --                          (a, length (filter (\x->x==a) polymer))
    --                          ) (toList alphabet)
    -- let leastCommon = filter (\(_,y) -> y == (minimum (map (snd) occurrences))) occurrences
    -- let mostCommon = filter (\(_,y) -> y == (maximum (map (snd) occurrences))) occurrences

    -- print occurrences
    -- print $ (snd (head mostCommon)) - (snd (head leastCommon))

    -- Part 1 & 2 - Not so naive
    let emptyCounts = map (\i->(head i,0)) instructions
    let productions = map (\i-> (head i,[[head (head i)] ++ last i, last i ++[last (head i)]])) instructions
    let seedCounts = map (\(pair, count)-> if contains pair seed then (pair, count+containsCount pair seed) else (pair, 0)) emptyCounts

    let finalCounts = growCounts desiredRounds seedCounts productions

    let letterCounts = occurrences finalCounts seed
    let leastCommon = filter (\(_,y) -> y == (minimum (map (snd) letterCounts))) letterCounts
    let mostCommon = filter (\(_,y) -> y == (maximum (map (snd) letterCounts))) letterCounts

    putStrLn "Part 1 & 2"
    print mostCommon
    print leastCommon
    print $ (snd (head mostCommon)) - (snd (head leastCommon))


    growCounts :: Int -> [(String,Int)] -> [(String,[String])]-> [(String,Int)]
    growCounts rounds counts productions
    | (rounds == 0) = counts
    | otherwise =
        growCounts (rounds - 1) (updateCounts counts productions) productions

    updateCounts :: [(String,Int)] -> [(String,[String])] -> [(String,Int)]
    updateCounts counts productions =
    foldl (\newcounts paircount ->
            let pair = fst paircount
                increase = snd paircount
                producedPairs = snd $ head $ filter (\(x,y)->x==pair) productions
                withAdded = map (\(p,count)->
                            if p `elem` producedPairs then (p, count + increase)
                                else (p,count)
                            ) newcounts
                in map (\(p,count)->
                            if p == pair then (pair, count - increase)
                                else (p,count)
                            ) withAdded
            ) counts counts

    occurrences :: [(String,Int)] -> String -> [(Char,Int)]
    occurrences pairCounts seed = foldl (updateOccurrences) [(last seed,1)] pairCounts

    updateOccurrences :: [(Char, Int)] -> (String,Int) -> [(Char,Int)]
    updateOccurrences charCounts pairCount =
    let p = fst pairCount
        c = snd pairCount
        withFst = if (head p) `elem` (map fst charCounts) then
                        (map (\(x,y)->if x == (head p) then (x,y+c) else (x,y)) charCounts)
                    else charCounts ++ [(head p, c)]
    in withFst


    growPolymer :: Int -> String -> [[String]] -> String
    growPolymer rounds seed instructions
    | (rounds == 0) = seed
    | otherwise = growPolymer (rounds  - 1) (applyInstructions seed instructions) instructions

    applyInstructions :: String -> [[String]] -> String
    applyInstructions seed instructions =
    let pairs = charPairs seed
    in foldl (\x y-> if (x /= "") && (y /= "") then (x) ++ (tail y) else x ++ y) "" $ map (\x ->
                let instruction = head (filter ((==x).head) instructions)
                in if (length instruction) > 0 then [head x] ++ (last instruction) ++ [last x] else ""
                ) pairs

    splitOnStr :: String -> String -> [String]
    splitOnStr d s = map (unpack.strip) $ splitOn (pack d) (pack s)

    substrings :: String -> [String]
    substrings s = foldl (++) [] (map inits (tails s))

    charPairs :: String -> [String]
    charPairs s = [x | g <- tails s, length g > 1, let x = take 2 g]

    contains :: String -> String -> Bool
    contains needle haystack =
    let matches = map (== needle) (substrings haystack)
    in foldl (||) False matches

    containsCount :: String -> String -> Int
    containsCount needle haystack =
    let matches = map (\x-> if x == needle then 1 else 0) (substrings haystack)
    in foldl (+) 0 matches

    getLines::IO([String])
    getLines = do
    s <- getContents
    pure(lines s)