Problem:
Score : 300 points

Problem Statement

You are given an integer N.

Find a triple of positive integers h, n and w such that 4/N = 1/h + 1/n + 1/w.

If there are multiple solutions, any of them will be accepted.

Constraints

It is guaranteed that, for the given integer N, there exists a solution such that h,n,w \leq 3500.

Inputs

Input is given from Standard Input in the following format:

N

Outputs

Print a triple of positive integers h, n and w that satisfies the condition, in the following format:

h n w

Sample Input 1

2

Sample Output 1

1 2 2

4/2 = 1/1 + 1/2 + 1/2.

Sample Input 2

3485

Sample Output 2

872 1012974 1539173474040

It is allowed to use an integer exceeding 3500 in a solution.

Sample Input 3

4664

Sample Output 3

3498 3498 3498

Solution in Haskell (GHC 7.10.3) (judge verdict: Accepted)

import Data.List
import Data.Maybe

countPower :: Int -> Int -> (Int, Int)
countPower c n = if n `mod` c /= 0 then (n, 0)
                 else (m, 1 + cp)
  where (m, cp) = countPower c (n `div` c)

        
pfact :: Int -> [(Int, Int)]
pfact n = pfact0 n [2..]  []
  where
    pfact0 :: Int -> [Int] -> [(Int, Int)] -> [(Int, Int)]
    pfact0 n (c : cands) pans =
      let (rem, power) = countPower c n
          nextCands = filter (\x -> x `mod` c /= 0) cands
      in if power >= 1 then pfact0 rem nextCands ((c, power) : pans)
         else if c * c <= n then pfact0 rem nextCands pans
              else if n == 1 then reverse pans
                   else reverse ((n,1) : pans)

divisors :: Int -> [Int]
divisors n = sort (divis0 (pfact n))
  where
    divis0 [] = [1]
    divis0 ((p,r) : prs) =
      concatMap (\x -> map (* x) (divis0 prs)) (take (r + 1) (iterate (* p) 1))

qcOddM :: Int -> [Int]
qcOddM n = head (mapMaybe f [1..])
  where
    f :: Int -> Maybe [Int]
    f r = let (x, y) = (4 * r, n * r) in do
      as <- selSum 3 x (reverse (divisors y))
      return (map (div y) as)


-- Find k members from ys s.t. the sum equals to x.
-- ys are in descending order.
selSum :: Int -> Int -> [Int] -> Maybe [Int]
selSum k x ys
  | k == 0 && x == 0 = Just []
  | k == 0           = Nothing
  | otherwise        = let ys1 = dropWhile (> x) ys in
      case ys1 of
        [] -> Nothing
        (y:ys2) -> case selSum (k - 1) (x - y) ys1 of
          Just as -> Just (y:as)
          Nothing -> selSum k x ys2

qcBody :: Int -> [Int]
qcBody n | n `mod` 2 == 0 = let k = n `div` 2 in [k, 2*k, 2*k]
         | otherwise = qcOddM n

main :: IO ()
main = do
  line <- getLine
  let n = read line :: Int
  putStrLn (concat (intersperse " " (map show (qcBody n))))