Monthly Archives: June 2012

Euler 89 – Haskell Redux

Just for kicks I decided to revisit my Roman numeral routines from Euler 89.

Admittedly, my earlier Python algorithms were not the most efficient, but they got the job done. Thought it might be worth seeing if Haskell can do it better. As usual, I re-wrote some of the more tighter online routines for clarify and fed the Euler roman.txt file through it to get the same answer.

import Data.Maybe

dec2num :: Integer -> String
dec2num x
	| x == 0 = ""
	| otherwise = b ++ dec2num (x - a)
	where
		(a, b) = head $ filter ((<= x) . fst)
			$ zip [1000,900,500,400,100,90,50,40,10,9,5,4,1]
			["M","CM","D","CD","C","XC","L","XL","X","IX","V","IV","I"]

num2dec :: String -> Integer
num2dec n = fst $ foldr (\p (t,s) -> if p >= s then (t+p,p) else (t-p,p)) (0,0)
	$ map (fromJust . flip lookup numMap) n
	where
		numMap = zip "IVXLCDM" [1,5,10,50,100,500,1000]

main = do
	raw <- readFile "roman.txt"
	print $ (sum [length s|s <- lines raw]- sum [length $ dec2num $ num2dec s|s <- lines raw])

Euler Problem 105 – Disjoint Sets

The interesting thing about this one was that I had to figure out how to load a file in Haskell by using IO inside a Monad. Maybe something pretty basic, but still a novel concept. And a little weird.

This solution could be considered a brute force solution, but it still runs in about 45 seconds on an old PC. The routine first reads the file, splits the lines, then converts the strings into Integers.

For each set, it calculates the perfect series of sub-sets (tricky understanding disjoint sets), then creates a test series against the criteria. Then it simply sums up each set if the sub-set counts are the same.

Now to solve for related problems 103 and 106.

import Data.List
import Data.List.Split

testSubs :: [Integer] -> [Integer] -> Bool
testSubs b c
	| sb /= sc && lb > lc && sb > sc = True
	| sb /= sc && lb <= lc = True 
	| otherwise = False
	where
		sb = sum b
		sc = sum c
		lb = length b
		lc = length c

isSpecial :: [Integer] -> Bool
isSpecial set
	| perfectSet == testSet = True
	| otherwise = False
	where
		list = init $ tail $ subsequences set
		perfectSet = [(b,c)| b <- list, c <- list, b /= c]
		testSet = [(b,c)| b <- list, c <- list, b /= c && testSubs b c]
		
main = do
	raw <- readFile "sets.txt"
	print $ sum [sum $ clean x | x <- [splitOn "," y | y <- lines raw], isSpecial $ clean x]
	where
		clean = map read

Euler Problem 144 – Laser Bounce

This one is interesting because its a real world application, albeit perhaps a little simplified from the real world so that it fits into the Euler framework. Here a great explanation and solution of the problem using Java. For me the challenge is in translating from imperative to functional, which I found to be pretty fun. Had to wrap my brain around using tuples larger than a pair and how to redefine iterative variables.

I came up with a recursive routine to calculate all the bounces with the data contained in list of tuples. The routine reads the last coordinates from the list, and calculates new coordinates. If the results are within the exit range, return the list as is, otherwise add new coordinates to list and loop. The main function just counts the length of the list. Easy.

quad :: Double -> Double -> Double -> Double
quad m2 n x2
	| dx1 > dx2 = ans1
	| otherwise = ans2
	where
		a = 4 + m2 * m2
		b = 2 * m2 * n
		c = n * n - 100
		ans1 =  (-b + sqrt (b * b - 4 * a * c)) / (2 * a)
		ans2 =  (-b - sqrt (b * b - 4 * a * c)) / (2 * a)
		dx1 = abs (x2 - ans1)
		dx2 = abs (x2 - ans2)

bounce :: [(Double, Double, Double, Double)] -> [(Double, Double, Double, Double)]
bounce coords
	| y2 > 0 && x2 > -0.01 && x2 < 0.01 = coords
	| otherwise = bounce $ coords ++ [(x1, y1, x2, y2)]
	where
		(x1', y1', x2', y2') = last coords
		m0 = (y2' - y1') / (x2' - x1')
		m1 = -4 * x2' / y2'
		tempX = x2'
		tempY = y2'
		bigX = (m0 - m1) / ( 1 + m0 * m1)
		m2 = (m1 - bigX) / ( 1 + bigX * m1)
		b = (y2' - m2 * x2')
		(x1, y1, x2, y2) = (tempX, tempY, quad m2 b x2', m2 * x2 + b)
	
main = print $ length $ bounce [(0, 10.1, 1.4, -9.6)]

Euler Problem 243 – Always the Totient

OK, so I had to look up the answer to this one. In my defence I did lots of research and determined that the resilience is related (once again) to Euler’s Totient function, specifically the relationship R(d) = phi(d)/(d-1). I figured that by using this relationship (and looking for R(d) lower than the ratio given) was the trick instead of having to brute force it. Nope. That is the brute force method. Ran for days and got nowhere.

So I broke down and looked up a solution. There aren’t very many for this one. Most were in interative languages like Ruby, which don’t help me. I did find one amazing solution is Haskell here, but for the life of me I don’t know why it works. I’ve adapted it and replaced as much as I can with clearer functions to help explain it. Perhaps not as efficient, but it still runs in less than a second.

Step One: Generate lists of primes and totients.
Step Two: Generate a list primorials consisting of tuples based on products of primes and totients.
Step Three: Use a recursive routine starting with the primorials list and a multiplier (m) of 1. If the current list head * m == the next primorial, then drop the head and loop. If the current list head * m is than the target then return it, otherwise increment m and loop.
Step Four: Shrug shoulders, open arms with palms upward, crinkle forehead, take a deep sign, and say, “WTF!”

import Data.List.Ordered

primes :: [Integer]
primes = 2 : sieve [3,5..] where
	sieve [] = []
	sieve (p:xs) = p : sieve (xs `minus` [p*p, p*p+2*p..])

totient :: Integer -> Integer
totient n = fromIntegral $ length [x | x <- [1..n], gcd x n == 1]

primorials :: [(Integer, Integer)]
primorials = [(product $ take x primes, product $ map totient $ take x primes) | x <- [1..]]

findRes :: [(Integer, Integer)] -> Integer -> Integer
findRes ((cpri,cphi):(npri,nphi):pps) m
	| cpri * m == npri = findRes ((npri,nphi):pps) 1
	| fromIntegral (cphi * m) / fromIntegral ((cpri * m) - 1) < ratio = cpri * m
	| otherwise = findRes ((cpri,cphi):(npri,nphi):pps) (m + 1)
	where ratio = 15499/94744

main = print $ findRes primorials 1

Euler Problem 95 – Recursion

After I got this one, I went to the Euler Project problem thread and wanted to read up on what other Haskellers had done. I found lots of posted Haskell routines that make the solution overly complicated, and look like spaghetti. My solution is made of nice and pretty code.

This problem I stared at for a long time. Its not a very difficult problem, but it can really only be solved recursively using native Haskell code. I will not use any mutable arrays. So this is really my first recursive routine. Admittedly, I ball-parked the upper limit to 15K, and got the answers on the first try. This routine runs on an old PC in under a minute.

sumdiv :: Integer -> Integer
sumdiv n = sum $ 1 : filter ((== 0) . rem n) [2 .. n `div` 2]

build :: [Integer] -> [Integer]
build chain
	| (last chain) == 1 = []
	| (last chain) > 1000000 = []
	| (last chain) `elem` (init chain) = chain
	| otherwise = build (chain ++ [sumdiv (last chain)])

main = print $ snd $ maximum [(length c, minimum c) | n<-[12496..15000], let c=build [n], c /= []]