extra/project-euler/061/061.factor

   1 ! Copyright (C) 2023 Giftpflanze
   2 ! See https://factorcode.org/license.txt for BSD license
   3
   4 USING: arrays assocs assocs.extras grouping kernel math
   5 project-euler.common ranges sequences sequences.extras ;
   6
   7 IN: project-euler.061
   8
   9 ! https://projecteuler.net/problem=61
  10
  11 ! DESCRIPTION
  12 ! -----------
  13
  14 ! Triangle, square, pentagonal, hexagonal, heptagonal, and
  15 ! octagonal numbers are all figurate (polygonal) numbers and are
  16 ! generated by the following formulae:
  17
  18 ! Triangle   P(3,n) = n(n+1)/2  1, 3, 6, 10, 15, ...
  19 ! Square     P(4,n) = n²        1, 4, 9, 16, 25, ...
  20 ! Pentagonal P(5,n) = n(3n-1)/2 1, 5, 12, 22, 35, ...
  21 ! Hexagonal  P(6,n) = n(2n-1)   1, 6, 15, 28, 45, ...
  22 ! Heptagonal P(7,n) = n(5n-3)/2 1, 7, 18, 34, 55, ...
  23 ! Octagonal  P(8,n) = n(3n-2)   1, 8, 21, 40, 65, ...
  24
  25 ! The ordered set of three 4-digit numbers: 8128, 2882, 8281,
  26 ! has three interesting properties.
  27
  28 ! 1. The set is cyclic, in that the last two digits of each
  29 ! number is the first two digits of the next number (including
  30 ! the last number with the first).
  31
  32 ! 2. Each polygonal type: triangle (P(3,127) = 8128), square
  33 ! (P(4,91) = 8281), and pentagonal (P(5,44) = 2882), is
  34 ! represented by a different number in the set.
  35
  36 ! 3. This is the only set of 4-digit numbers with this property.
  37 !
  38 ! Find the sum of the only ordered set of six cyclic 4-digit
  39 ! numbers for which each polygonal type: triangle, square,
  40 ! pentagonal, hexagonal, heptagonal, and octagonal, is
  41 ! represented by a different number in the set.
  42
  43
  44 ! SOLUTION
  45 ! --------
  46
  47 ! https://en.wikipedia.org/wiki/Polygonal_number#Formula
  48 ! nth s-gonal number P(s,n) = [(s-2)n²-(s-4)n]/2
  49 : nth-polygon ( n s -- p )
  50     [ [ sq ] dip 2 - * ] [ 4 - * ] 2bi - 2 / ;
  51
  52 : (4-digit-polygons) ( s -- seq )
  53     [ V{ } clone 1 ] dip
  54     [ 2dup nth-polygon dup 9999 > ] [
  55         dup 1000 >= [ dupd 2array reach push ] [ drop ] if
  56         [ 1 + ] dip
  57     ] until 3drop ;
  58
  59 : 4-digit-polygons ( -- seq )
  60     3 8 [a..b] [ (4-digit-polygons) ] map-concat ;
  61
  62 : cycle? ( chain -- ? )
  63     2 circular-clump [
  64         values first2 [ 100 mod ] [ 100 /i ] bi* =
  65     ] all? ;
  66
  67 : links ( polygons chain -- chains )
  68     [ keys '[ _ member? ] reject-keys ] keep
  69     tuck values last 100 mod '[ 100 /i _ = ] filter-values
  70     [ suffix ] with map ;
  71
  72 : find-cycle ( polygons chain length -- chain )
  73     2dup [ length ] dip = [
  74         drop nip [ cycle? ] keep and
  75     ] [
  76         [ dupd links ] dip '[ _ find-cycle ] with map-find drop
  77     ] if ;
  78
  79 : euler061 ( -- n )
  80     4-digit-polygons dup [ 8 = ] filter-keys [
  81         1array 6 find-cycle
  82     ] with map-find drop values sum ;
  83
  84 SOLUTION: euler061