ホーム - Project Euler

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:

The ordered set of three $4$-digit numbers: $8128$, $2882$, $8281$, has three interesting properties.

1. 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).
2. 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.
3. 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.

巡回図形数¶

三角数, 四角数, 五角数, 六角数, 七角数, 八角数は多角数であり, それぞれ以下の式で生成される.

3つの4桁の数の順番付きの集合 (8128, 2882, 8281) は以下の面白い性質を持つ.

1. この集合は巡回的である. 最後の数も含めて, 各数の後半2桁は次の数の前半2桁と一致する
2. それぞれ多角数である: 三角数 ($P_{3,127}=8128$), 四角数 ($P_{4,91}=8281$), 五角数 ($P_{5,44}=2882$) がそれぞれ別の数字で集合に含まれている
3. $4$桁の数の組で上の2つの性質を持つのはこの組だけである.

三角数, 四角数, 五角数, 六角数, 七角数, 八角数が全て表れる6つの巡回する4桁の数からなる唯一の順序集合の和を求めよ.

(import (scheme base)
        (gauche base))

(define (triangle-num num)
  (let loop ([index 1] [result '()])
    (let ([current (/ (* index (+ index 1))
                      2)])
      (if (<= num current)
        result
        (loop (+ index 1)
              (cons current result))))))

(define (square-num num)
  (let loop ([index 1] [result '()])
    (let ([current (* index index)])
      (if (<= num current)
        result
        (loop (+ index 1)
              (cons current result))))))

(define (pentagonal-num num)
  (let loop ([index 1] [result '()])
    (let ([current (/ (* index
                         (- (* index 3)
                            1))
                      2)])
      (if (<= num current)
        result
        (loop (+ index 1)
              (cons current result))))))

(define (hexagonal-num num)
  (let loop ([index 1] [result '()])
    (let ([current (* index
                      (- (* index 2)
                         1))])
      (if (<= num current)
        result
        (loop (+ index 1)
              (cons current result))))))

(define (heptagonal-num num)
  (let loop ([index 1] [result '()])
    (let ([current (/ (* index
                         (- (* index 5)
                            3))
                      2)])
      (if (<= num current)
        result
        (loop (+ index 1)
              (cons current result))))))

(define (octagonal-num num)
  (let loop ([index 1] [result '()])
    (let ([current (* index
                      (- (* index 3)
                         2))])
      (if (<= num current)
        result
        (loop (+ index 1)
              (cons current result))))))

(define (four-digit-list proc)
  (filter (^n
            (and (<= 1000 n 9999)
                 (<= 10 (mod n 100))))
          (proc 10000)))

(define (possible-4digit-list)
  (let loop ([rest `((3 . ,triangle-num)
                     (4 . ,square-num)
                     (5 . ,pentagonal-num)
                     (6 . ,hexagonal-num)
                     (7 . ,heptagonal-num)
                     (8 . ,octagonal-num))]
             [result '()])
    (if (null? rest)
      (reverse result)
      (let ([base (caar rest)]
            [proc (cdar rest)])
        (loop (cdr rest)
              (append
                (map (cut cons base <>)
                     (four-digit-list proc))
                result))))))

(define (delete-same-base cell lis)
  (let ([base (car cell)])
    (filter (^c (not (= base (car c))))
            lis)))

(define (findall-next-num num lis)
  (assume exact-integer? num)
  (assume (<= 1010 num 9999))
  (let ([lower (+ (* (mod num 100) 100) 10)]
        [upper (+ (* (mod num 100) 100) 99)])
    (filter (^c (<= lower (cdr c) upper))
            lis)))

(define (find-cyclical-num)
  (let loop ([rest (possible-4digit-list)]
             [result '()])
    (cond
      [(null? rest)
       (assume (not (null? result)))
       (and (not (null? (findall-next-num
                          (cdar result)
                          (last-pair result))))
            (reverse result))]
      [(null? result)
       (assume (not (null? rest)))
       (any (^c
              (loop (delete-same-base c rest)
                    (cons c result)))
            rest)]
      [else
        (let ([candidate (findall-next-num (cdar result) rest)])
          (and (not (null? candidate))
               (any (^c
                      (loop (delete-same-base c rest)
                            (cons c result)))
                    candidate)))])))

(define answer-61
  (apply +
         (map (cut cdr <>)
              (find-cyclical-num))))

(format #t "61: ~d~%" answer-61)