Compiler Explorer - Haskell

-- See "Ponder This" Nov 2025 -- https://research.ibm.com/haifa/ponderthis/challenges/November2025.html import Control.Monad hiding (join) -- Note this is expository code and contains far more than the solution -- which is just a couple of lines. -- First we write a naive solution that works for really small problems. -- Just for testing. -- church n f x: Church numeral, ie. apply f n times to x. church 0 f x = x church n f x = church (n - 1) f (f x) -- First problem rewrite1 'G' = "T" rewrite1 'T' = "CA" rewrite1 'C' = "TG" rewrite1 'A' = "C" -- Print result of applying rewrite 5 times to "cat" test1 = do putStrLn $ "Rewrite1^5 \"CAT\":" print $ church 5 (concatMap rewrite1) "CAT" -- As a warmup consider this rewrite system: -- 0 -> 1 -- 1 -> 10 -- It's not hard to show that after k rewrites -- ...0 ends up with this length... len0 k = fib (k + 1) -- and 1 ends up with this length... len1 k = fib (k + 2) fib :: Integer -> Integer fib n = fst (fib' n) where fib' 0 = (0, 1) fib' k = let (a, b) = fib' (k `div` 2) c = a * (2 * b - a) d = a * a + b * b in if odd k then (d, c + d) else (c, d) -- I want two slightly different implementations -- with two different string representations. -- So let me abstract a bit to save typing: class StringLike a where -- Make a string from a single character. single :: Char -> a -- Concatenate one string after another of given length. join :: a -> Integer -> a -> a -- We want a lazy representation of strings so that when we -- concatenate together more than the number of atoms in the -- universe we don't run out of memory. -- Define a "rope" to be function which when given `i` tells you -- what character is at position `i`. type UltraLazyString = Integer -> Char instance StringLike UltraLazyString where join f l g i = if i < l then f i else g (i - l) single c = const c -- First note that with these rules: -- G -> T -- T -> CA -- C -> TG -- A -> C -- Then under quotient G, A -> 0 and T, C -> 1 we get the same -- rules as the 01 rewrite. So we can reuse `len0` and `len1` -- to compute the lengths. -- Here's a generic implementation for applying a rewrite -- of the form x -> y rule1:: StringLike a => Char -> (Integer -> a) -> Integer -> a rule1 letter c' k = if k == 0 then single letter else c' (k - 1) -- Here's a generic implementation for applying a rewrite -- of the form x -> yz assuming that `rewrite^k y` is `len1 k`. rule2:: StringLike a => Char -> (Integer -> a) -> (Integer -> a) -> Integer -> a rule2 letter c' a' k = if k == 0 then single letter else let k' = k - 1 in join (c' k') (len1 k') (a' k') -- Now the rules as given. g, t, c, a :: StringLike r => Integer -> r g = rule1 'G' t t = rule2 'T' c a c = rule2 'C' t g a = rule1 'A' c -- Redo the naive computation as a check. test2 = do putStrLn $ "redo of rewrite1^5 \"cat\":" print $ [(c 5 :: UltraLazyString) i | i <- [0..len1 5 - 1]] ++ [(a 5 :: UltraLazyString) i | i <- [0..len0 5 - 1]] ++ [(t 5 :: UltraLazyString) i | i <- [0..len1 5 - 1]] -- We need two tricks: -- 1. The obvious one that we only need `rewrite1^k` "c" because it is -- already very long. -- 2. We only need `k` to be 500 or less or so because applying `k` an even number -- of times just keeps extending the string and 500 iterations gets you -- something longer than 10^100. -- These are strange tricks because they both involve writing less code :) -- So magically we can get away with the following. -- It's 10^100 (or whatever) times faster than the naive solution but -- not instant. test3 = do putStrLn $ "Solution to first problem:" print [c @UltraLazyString 500 i | i <- [10 ^ 100 .. 10 ^ 100 + 1000 - 1]] -- But we can do better: -- Now define a string to be a function that given a range (instead -- of one index) prepends the appropriate substring to a list of -- characters. type UltraLazyString' = Integer -> Integer -> [Char] -> [Char] -- When we join two strings we need to handle the case where -- the range we request is split between the summands. instance StringLike UltraLazyString' where join f l g i j = if j < l -- range falls in f then f i j else if i >= l -- range falls in g then g (i - l) (j - l) -- split over f and g. else f i l . g 0 (j - l) single c i j = if j > i then (c :) else id test4 = do putStrLn $ "Better solution to first problem" print $ c @UltraLazyString' 500 (10 ^ 100) (10 ^ 100 + 1000) [] -- Now the second problem -- G -> T, -- T -> CA, -- C -> BR, -- A -> I, -- R -> B, -- B -> IS, -- I -> TG, -- S -> C -- Under the quotient R, G -> G; B, T -> T; I, C -> C; S, A -> A we get same rules -- as the first problem so again so lengths can be computed with `len0` and `len1`. -- The code is just like before. rewrite2 'G' = "T" rewrite2 'T' = "CA" rewrite2 'C' = "BR" rewrite2 'A' = "I" rewrite2 'R' = "B" rewrite2 'B' = "IS" rewrite2 'I' = "TG" rewrite2 'S' = "C" g', t', c', a', r', b', i', s' :: StringLike r => Integer -> r g' = rule1 'G' t' t' = rule2 'T' c' a' c' = rule2 'C' b' r' a' = rule1 'A' i' r' = rule1 'R' b' b' = rule2 'B' i' s' i' = rule2 'I' t' g' s' = rule1 'S' c' -- A quick check test5 = do putStrLn $ "Naive method rewrite2^10 \"R\":" print $ church 10 (concatMap rewrite2) "R" putStrLn $ "Fast method to rewrite2^10 \"R\":" print $ r' @UltraLazyString' 10 0 (len1 10) [] -- Repeating the comments above (except we now have period 4 instead of 2) -- we can write: test6 = do putStrLn $ "Solution to second problem" print $ r' @UltraLazyString' 500 (10 ^ 100) (10 ^ 100 + 1000) [] main = do test1 test2 test3 test4 test5 test6

godbolt.org