061_cyclical_figurate_numbers.hs

-- 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=n^2            1, 4,  9, 16, 25, ...
-- Pentagonal       P5,n=n(3n−1)/2      1, 5, 12, 22, 35, ...
-- Hexagonal        P6,n=n(2n−1)        1, 6, 15, 28, 45, ...
-- Heptagonal       P7,n=n(5n−3)/2      1, 7, 18, 34, 55, ...
-- Octagonal        P8,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 (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.Maybe
import Data.List

data NumType = Triangle
             | Square
             | Pentagon
             | Hexagon
             | Heptagon
             | Octagon
             deriving (Eq, Read, Show)

data DBEntry = DBEntry {numType :: NumType, number :: Integer, start :: String, end :: String}
             deriving (Eq, Read, Show)

triangleNums = [ n*(  n+1) `div` 2 | n <- [1..]]
squareNums   = [ n^2               | n <- [1..]]
pentaNums    = [ n*(3*n-1) `div` 2 | n <- [1..]]
hexaNums     = [ n*(2*n-1)         | n <- [1..]]
heptaNums    = [ n*(5*n-3) `div` 2 | n <- [1..]]
octaNums     = [ n*(3*n-2)         | n <- [1..]]

relevantRange = dropWhile (<1000) . takeWhile (<10000)

firstDigits :: Integer -> String
firstDigits = take 2 . show

lastDigits :: Integer -> String
lastDigits = drop 2 . show

database :: [DBEntry]
database = map (\(t,n) -> DBEntry t n (firstDigits n) (lastDigits n)) $
              [(Triangle, n) | n <- relevantRange triangleNums]
           ++ [(Square, n) | n <- relevantRange squareNums]
           ++ [(Pentagon, n) | n <- relevantRange pentaNums]
           ++ [(Hexagon, n) | n <- relevantRange hexaNums]
           ++ [(Heptagon, n) | n <- relevantRange heptaNums]
           ++ [(Octagon, n) | n <- relevantRange octaNums]

databaseSmall :: [DBEntry]
databaseSmall = map (\(t,n) -> DBEntry t n (firstDigits n) (lastDigits n)) $
                   [(Triangle, n) | n <- relevantRange triangleNums]
                ++ [(Square, n) | n <- relevantRange squareNums]
                ++ [(Pentagon, n) | n <- relevantRange pentaNums]

problem = [ (number a, number b, number c, number d, number e, number f)
          | a <- database, b <-database, c <-database, d <- database, e <- database, f <- database,
          end a == start b,
          end b == start c,
          end c == start d,
          end d == start e,
          end e == start f,
          end f == start a]


-- PROBLEMS: does not check for dircle, only for chain, does not check for full length (<- why?)
foo :: [DBEntry] -> [DBEntry] -> [DBEntry] -> [(Integer, NumType)]
foo chain list startList
  | null startList = []
  | null list && null chain = foo [] startList (tail startList)
  | null list = if start (head chain) == end (last chain)
                  then map (\x -> (number x, numType x)) chain
                  else foo [] [] startList
  | null chain = foo [head list] (filter (\ x -> numType x /= numType (head list)) list) startList
  | otherwise = if isJust c
                  then foo (fromJust c:chain) l startList
                  else foo [] [] startList
  where
    c = find (\x -> end x == start (head chain)) list
    l = filter (\x -> numType x /= numType (fromJust c)) list