Problem 212

212 Combined Volume of Cuboids
Problem 212 - Project Euler
はじめは平面走査で行こうと思ったが…
遅い。おそらく、直方体が密に存在するから。
そこで、方針を変更。
分割統治で。大きな直方体はないから、大丈夫でしょう。

import Data.List ((!!),  mapAccumL)
import Control.Arrow ((***))

type Cuboid = ([Int], [Int])

lagFib :: [Integer]
lagFib = map s [1..55] ++ zipWith add lagFib (drop 31 lagFib)
    where s k = (100003 - 200003*k + 300007*k^3) `mod` 1000000
          add x y = (x + y) `mod` 1000000

cuboids :: [Cuboid]
cuboids = map h.getCube $ lagFib
    where getCube (x:y:z:dx:dy:dz:fibs) = (map f [x,y,z], map g [dx,dy,dz]) : getCube fibs
          f x = fromIntegral $ x `mod` 10000
          g x = fromIntegral $ 1 + (x `mod` 399)
          h (p,dp) = (p, zipWith (+) p dp)

replace :: Int -> a -> [a] -> [a]
replace n x xs = let (a,b:cs) = splitAt n xs
                 in a ++ x:cs

split :: Int -> Int -> Cuboid -> ([Cuboid], [Cuboid])
split n t c@(p1, p2) | t <= p1!!n = ([], [c])
                     | p2!!n <= t = ([c], [])
                     | otherwise  = ([c1], [c2])
    where c1 = (p1, replace n t p2)
          c2 = (replace n t p1, p2)

partition :: [Cuboid] -> (Int, Int) -> ([Cuboid], [Cuboid])
partition cs (n,t) = (concat***concat).unzip.map (split n t) $ cs

volume :: Cuboid -> Integer
volume (p1,p2) = product.map toInteger.zipWith (-) p2 $ p1

combineVolume :: [Cuboid] -> Integer
combineVolume [] = 0
combineVolume (c@(p1,p2):cs) = volume c + sum (map combineVolume $ outer ++ inner)
    where (rs,outer) = mapAccumL partition cs $ zip [0..2] p2
          (_,inner)  = mapAccumL partition' rs $ zip [0..2] p1
          partition' xs = (\(a,b) -> (b,a)).partition xs

main :: IO ()
main = print.combineVolume.take 50000 $ cuboids

ついでに、ダメだった平面走査。

{-# LANGUAGE BangPatterns #-}
import Data.List (sort, foldl')
import Data.Set (empty, toList, insert, delete)

lagFib :: [Integer]
lagFib = map s [1..55] ++ zipWith add lagFib (drop 31 lagFib)
    where s k = (100003 - 200003*k + 300007*k^3) `mod` 1000000
          add x y = (x + y) `mod` 1000000
cuboids = getCube lagFib
    where getCube (x:y:z:dx:dy:dz:fibs) = ((f x,f y,f z),(g dx,g dy,g dz)):getCube fibs
          f x = fromIntegral $ x `mod` 10000
          g x = fromIntegral $ 1 + (x `mod` 399)

data Event = L | U deriving (Eq, Ord, Show)
type Coord = Int
type Line = (Coord, Coord)
type Box  = ((Coord, Coord), (Coord,Coord))
type Cube = ((Coord, Coord, Coord), (Coord, Coord, Coord))

combineLine :: [Line] -> Integer
combineLine = fst.foldl' step (0,0).sort

step (!s,!p) (!x,!dx) | x+dx < p  = (s, p)
                      | p < x     = (s+ toInteger dx, x+dx)
                      | otherwise = (s+ toInteger (x+dx-p), x+dx)

boxToEvent :: Box -> [(Coord, Line, Event)]
boxToEvent ((x,y), (dx,dy)) = [(y,l,L),(y+dy,l,U)]
    where l = (x,dx)

combineBox :: [Box] -> Integer
combineBox = snd.foldl' sweep ((0,empty,0), 0).sort.concatMap boxToEvent
    where sweep ((!h,!ls,!w), !a) (!y,!l,!e) =
              let a' = a + w*(toInteger (y-h))
                  ls' = case e of L -> insert l ls
                                  U -> delete l ls
                  w' = combineLine.toList $ ls'
              in ((y,ls',w'), a')

cubeToEvent :: Cube -> [(Coord, Box, Event)]
cubeToEvent ((x,y,z), (dx,dy,dz)) = [(z,b,L),(z+dz,b,U)]
    where b = ((x,y), (dx,dy))

combineCube :: [Cube] -> Integer
combineCube = snd.foldl' sweep ((0,empty,0), 0).sort.concatMap cubeToEvent
    where sweep ((!h,!bs,!a), !v) (!z,!b,!e) =
              let v' = v + a*(toInteger(z-h))
                  bs' = case e of L -> insert b bs
                                  U -> delete b bs
                  a' = combineBox.toList $ bs'
              in ((z,bs',a'), v')

main :: IO ()
main = print.combineCube.take 100 $ cuboids