euler/061.hs

-- Problem 61
--
-- Triangle, square, pentagonal, hexagonal, heptagonal, and octagonal numbers are all figurate (polygonal) numbers and are generated by the following formulae:
-- 
-- Triangle	 	    P3,n=n(n+1)/2	 	1, 3, 6, 10, 15, ...
-- Square	 	    P4,n=n2	 	        1, 4, 9, 16, 25, ...
-- Pentagonal	 	P5,n=n(3n1)/2	 	1, 5, 12, 22, 35, ...
-- Hexagonal	 	P6,n=n(2n1)	 	    1, 6, 15, 28, 45, ...
-- Heptagonal	 	P7,n=n(5n3)/2	 	1, 7, 18, 34, 55, ...
-- Octagonal	 	P8,n=n(3n2)	 	    1, 8, 21, 40, 65, ...
-- The ordered set of three 4-digit numbers: 8128, 2882, 8281, has three interesting properties.
-- 
-- The set is cyclic, in that the last two digits of each number is the first two digits of the next number (including the last number with the first).
-- Each polygonal type: triangle (P3,127=8128), square (P4,91=8281), and pentagonal (P5,44=2882), is represented by a different number in the set.
-- This is the only set of 4-digit numbers with this property.
-- Find the sum of the only ordered set of six cyclic 4-digit numbers for which each polygonal type: triangle, square, pentagonal, hexagonal, heptagonal, and octagonal, is represented by a different number in the set.

import Data.List (sort,(\\) )

triangles, squares, pentagonals, hexagonals, heptagonals, octagonals :: [Int]
triangles   = fourNumbers $ map (\ n -> (n * (n+1)) `div` 2)  [0..]
squares     = fourNumbers $ map (\ n -> n^2)              [0..]
pentagonals = fourNumbers $ map (\ n -> n*(3*n - 1)`div`2)    [0..]
hexagonals  = fourNumbers $ map (\ n -> n*(2*n - 1))      [0..]
heptagonals = fourNumbers $ map (\ n -> n*(5*n - 3)`div`2)    [0..]
octagonals  = fourNumbers $ map (\ n -> n*(3*n - 2))      [0..]

fourNumbers :: [Int] -> [Int]
fourNumbers = takeWhile (<10000) . dropWhile (<1000)

polynumbers=[triangles,squares,pentagonals, hexagonals, heptagonals, octagonals]
interestingNumbers=polynumbers

inum = sort $ concat polynumbers

-- compatibles 1234 [3212,3412,1123] => [3412]
-- last two digit of x are equal to first to digit of element of the list
isCompatible :: Int -> Int -> Bool
isCompatible x y = (x `rem` 100) == (y `div` 100)
compatibles :: Int -> [Int] -> [Int]
compatibles x = filter (isCompatible x)

sub :: Int -> Int -> [Int]
-- sub x = compatibles x $ dropWhile (<= x) $ inum
sub x i = compatibles x $ interestingNumbers !! i

solution = do
    i <- [0..5]
    x <- interestingNumbers !! i
    j <- [0..5] \\ [i]
    y <- sub x j
    k <- [0..5] \\ [i,j]
    z <- sub y k
    l <- [0..5] \\ [i,j,k]
    t <- sub z l
    m <- [0..5] \\ [i,j,k,l]
    u <- sub t m
    n <- [0..5] \\ [i,j,k,l,m]
    v <- sub u n
    if isCompatible v x
        then
            return [(x,i),(y,j),(z,k),(t,l),(u,m),(v,n)]
        else
            return []

main = do
    let toto = head $ filter (/=[]) solution
    print $ map (\(x,y) -> (x,y+3)) toto
    print $ sum $ map fst toto