project-euler/061-cyclical-figurate-numbers.hs at master · tdons/project-euler · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
#!/usr/bin/env stack
{- stack runghc --resolver lts-6.0 -}
{- https://projecteuler.net/problem=61
Problem 61
Cyclical figurate numbers

Triangle, square, pentagonal, hexagonal, heptagonal, and octagonal numbers are all figurate (polygonal) numbers and are generated by the following formulae:

Triangle	 	P_{3,n}=n(n+1)/2	 	1, 3, 6, 10, 15, ...
Square	 	    P_{4,n}=n2	 	        1, 4, 9, 16, 25, ...
Pentagonal	 	P_{5,n}=n(3n−1)/2	 	1, 5, 12, 22, 35, ...
Hexagonal	 	P_{6,n}=n(2n−1)	 	    1, 6, 15, 28, 45, ...
Heptagonal	 	P_{7,n}=n(5n−3)/2	 	1, 7, 18, 34, 55, ...
Octagonal	 	P_{8,n}=n(3n−2)	    	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 (P_{3,127}=8128), square (P_{4,91}=8281), and pentagonal (P_{5,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 as DL (permutations)

triangle :: Integral a => a -> a
triangle n = (n * (n + 1)) `div` 2

square :: Integral a => a -> a
square n = n * n

pentagonal :: Integral a => a -> a
pentagonal n = n * (3 * n - 1) `div` 2

hexagonal :: Integral a => a -> a
hexagonal n = n * (2 * n - 1)

heptagonal :: Integral a => a -> a
heptagonal n = n * (5 * n - 3) `div` 2

octagonal :: Integral a => a -> a
octagonal n = n * (3 * n - 2)

polygonals :: Integral a => [a -> a]
polygonals = [triangle, square, pentagonal, hexagonal, heptagonal, octagonal]

hasFourDigits :: (Integral a) => (a -> a) -> [a]
hasFourDigits fn = filter (>= 1000) . takeWhile (< 10000) $ map fn [1..]

split :: Integral a => [a] -> [(a, a, [a])]
split = map (\s -> (s `div` 100, s `mod` 100, [s]))

join :: Eq a => [(a, a, [a])] -> [(a, a, [a])] -> [(a, a, [a])]
join as bs = [(al, br, ax ++ bx) | (al, ar, ax) <- as, (bl, br, bx) <- bs, ar == bl]

main :: IO ()
main = print
     . sum
     . (\(l, r, xs) -> xs)
     . head
     . filter (\(l, r, xs) -> length xs == length polygonals && l == r)
     . concat
     . map (foldl1 join)
     . DL.permutations
     . map (split . hasFourDigits)
     $ polygonals