Problem 222

222 Sphere Packing
Problem 222 - Project Euler
球のパッキング．一般のパッキングは難しい（ナップサック，ビン・パッキング）．
しかし，これは状況がかなり特殊．
最小ではどうせ，綺麗に並ぶんだよ，と思い，小さい数で実験．
そして，予測．あってた．

height :: Int -> Int -> Int -> Double
height l r1 r2 = sqrt.fromIntegral $ l * ( 2 * (r1 + r2) - l)

pipe l rs = (+r).sum.map2 (height l) $ rs
    where map2 f xs = zipWith f xs $ tail xs
          r = fromIntegral $ head rs + last rs

p222 :: Integer
p222 = round.(1000*).pipe 100 $ [49,47..31] ++ [30,32..50]

実験も含めたコード．

import Data.List (minimumBy)
import Data.Ord (comparing)
import Control.Monad (liftM)
import System.Environment (getArgs)

height :: Int -> Int -> Int -> Double
height l r1 r2 = sqrt.fromIntegral $ l * ( 2 * (r1 + r2) - l)

pipe l rs = (+r).sum.map2 (height l) $ rs
    where map2 f xs = zipWith f xs $ tail xs
          r = fromIntegral $ head rs + last rs

p222 :: Integer
p222 = round.(1000*).pipe 100 $ [49,47..31] ++ [30,32..50]

minPipe :: Int -> [Int] -> (Double, [Int])
minPipe l rs = minimumBy (comparing fst) [(pipe l rs', rs') | rs' <- permutations rs]

main :: IO ()
main = do n <- liftM (read.head) getArgs
          print.minPipe 100 $ [50-n..50]

permutations            :: [a] -> [[a]]
permutations xs0        =  xs0 : perms xs0 []
  where
    perms []     _  = []
    perms (t:ts) is = foldr interleave (perms ts (t:is)) (permutations is)
      where interleave    xs     r = let (_,zs) = interleave' id xs r in zs
            interleave' _ []     r = (ts, r)
            interleave' f (y:ys) r = let (us,zs) = interleave' (f . (y:)) ys r
                                     in  (y:us, f (t:y:us) : zs)

ghc 6.8.2 には permutations がまだ，入ってなかった．
ところで，最小性の証明は？
あとで，フォーラムを探してみよう．