Source code in the racket programming language

#lang racket

(define names "
  audino bagon baltoy banette bidoof braviary bronzor carracosta charmeleon
  cresselia croagunk darmanitan deino emboar emolga exeggcute gabite girafarig
  gulpin haxorus heatmor heatran ivysaur jellicent jumpluff kangaskhan
  kricketune landorus ledyba loudred lumineon lunatone machamp magnezone
  mamoswine nosepass petilil pidgeotto pikachu pinsir poliwrath poochyena
  porygon2 porygonz registeel relicanth remoraid rufflet sableye scolipede
  scrafty seaking sealeo silcoon simisear snivy snorlax spoink starly tirtouga
  trapinch treecko tyrogue vigoroth vulpix wailord wartortle whismur wingull
  yamask")

(struct word (first last string) #:prefab)
(define words
  (for/list ([str (string-split names)])
    (word (string->symbol (substring str 0 1))
          (string->symbol (substring str (sub1 (string-length str))))
          str)))

(define (find-longest last words)
  (for/fold ([best '()])
            ([w (in-list words)]
             #:when (or (not last) (eq? last (word-first w))))
    (define long (cons w (find-longest (word-last w) (remq w words))))
    (if (> (length long) (length best)) long best)))

(define longest (find-longest #f words))
(printf "Longest chain found has ~a words:\n  ~a\n"
        (length longest) (string-join (map word-string longest) " -> "))


#lang racket
(require "pokemon-names.rkt")

;;; Some fundamentals... finding the first (henceforth referred to as "a") and last ("z")
;;; letters of a word can be computationally intensive... look at symbol->word, and you'll
;;; see that when we have to deal with a name like: "Mime Jr.", the last alphabetic letter
;;; is not the last character. And the first and last characters (at least) have to be
;;; case-normalised so they can be compared with char=? (it's not particulary helpful to
;;; map them down to integer character codes; we'll want to see them for debugging).
(define-struct word (sym char-a char-z) #:prefab)

;;; names are input as symbols both for ease of comparsion, and because it's easier to type
(define (symbol->word sym) 
  (let* ((str (symbol->string sym))
         (chrs (string->list str))
         (fst (for/first ((c chrs) #:when (char-alphabetic? c)) (char-downcase c)))
         (lst (for/last ((c chrs) #:when (char-alphabetic? c)) (char-downcase c))))
    (make-word sym fst lst)))

;;; We're sometimes not interested in debugging a chain of; just in knowing how long it is
;;; and what its extreme characters are. This does the trick.
(define (summarise-chain c)
  (format "(~a.~a.~a)" (word-char-a (first c)) (sub1 (length c)) (word-char-z (last c))))

;; Test the above (run `raco test last_letter-first_letter-common.rkt`)
(define-syntax-rule (hash-set-or-remove hsh key val remove-pred?)
  (let ((v val))
    (if (remove-pred? v)
        (hash-remove hsh key)
        (hash-set hsh key v))))

(define-syntax-rule (find-a-in-chain-pool chains a dont-match-sym)
  (for/first ((c chains)
              (i (in-naturals)) ;; usually need an index for regenerating chains pool
              ;; a word can only exist in one chain, so this compares chains' identities
              #:unless (eq? (word-sym (first c)) dont-match-sym)
              #:when (char=? (word-char-a (first c)) a))
    (cons i c)))

(define-syntax-rule (copy-list-ignoring-indices lst i1 i2)
  (for/list ((idx (in-naturals))
             (e (in-list lst))
             #:unless (= idx i1)
             #:unless (= idx i2))
    e))

;; Simple ... find a chain that can be put on the end of c... append it, and
;; reiterate
(define (append-ab..bz-chains chain chain-idx chains)
  (let* ((a1.chain-a (find-a-in-chain-pool chains (word-char-z (last chain)) (word-sym (first chain)))))
    (and a1.chain-a
         (let ((a1.chain-idx (first a1.chain-a))
               (a1.chain-chain (rest a1.chain-a)))
           (cons (append chain a1.chain-chain)
                 (copy-list-ignoring-indices chains chain-idx a1.chain-idx))))))

;; If chain has an a..a loop in it, then we see if we can take that loop, and
;; place it in a longer chain at a point where a is used.
;;
;; `chain` is the shorter chain containing the loop
(define (merge-chain-into-chain-accepting-a..a-in-chain chain chain-idx chains)
  ;; for a..a loops in chain, returns a hash from the looped char, to the longest
  ;; found loop
  (define (find-a..a-loops chain)
    (let ((chain-length (length chain)))
      (for*/fold
          ((hsh (hash)))
        ((sub-range-start (in-range chain-length))
         (aa (in-value (word-char-a (list-ref chain sub-range-start))))
         (sub-range-end (in-range sub-range-start chain-length))
         #:when (eq? aa (word-char-z (list-ref chain sub-range-end)))
         (range-length (in-value (add1 (- sub-range-end sub-range-start)))))
        (hash-update
         hsh aa
         (lambda (longest-range)
           (if (and longest-range (> (third longest-range) range-length))
               longest-range
               (list sub-range-start sub-range-end range-length)))
         #f))))
  
  (let* ((chain-first-name (word-sym (first chain)))
         (chain-length (length chain))         
         (a..a-list (sort (hash->list (find-a..a-loops chain)) > #:key third)))                       
    (for*/first (((chain2 chain2-idx) (in-parallel (in-list chains) (in-naturals)))
                 #:unless (eq? chain-first-name (word-sym (car chain2)))
                 (chain2-length (in-value (length chain2)))
                 #:when (>= chain2-length chain-length) ; only move the largest a..a-subchain into a larger chain
                 (a..a (in-list a..a-list))
                 ((insertion-point-word insertion-point-idx) (in-parallel (in-list chain2) (in-naturals)))
                 #:when (eq? (car a..a) (word-char-a insertion-point-word)))
      (let* ((new-chain (append (take chain (second a..a)) (drop chain (add1 (third a..a)))))
             (a..a-chain (take (drop chain (second a..a)) (fourth a..a)))
             (new-chain2 (append (take chain2 insertion-point-idx) a..a-chain (drop chain2 insertion-point-idx))))
        (let ((new-chains (copy-list-ignoring-indices chains chain-idx chain2-idx)))
          (if (null? new-chain) (cons new-chain2 new-chains)
              (cons new-chain (cons new-chain2 new-chains))))))))

;; this is a bit more combinatorially intensive... for all c2, substitute a
;; subrange in c2 that is longer than an equivalent subrange in c
(define (merge-subranges-of-chains-into-chain chain chain-idx chains) 
  (let ((chain-first-name (word-sym (first chain)))
        (chain-length (length chain))
        (chain-first-a (word-char-a (first chain)))
        (chain-last-z (word-char-z (last chain))))
    (for*/first ; try to replace a subrange in c2 with c
        (((chain2 chain2-idx) (in-parallel (in-list chains) (in-naturals)))
         (chain2-length (in-value (length chain2)))
         #:unless (eq? chain-first-name (word-sym (car chain2)))
         (c2-sub-range-start (in-range chain2-length))
         (c2-sub-range-end (in-range c2-sub-range-start
                                     (min chain2-length (+ c2-sub-range-start chain-length))))
         #:unless (and (= c2-sub-range-start 0) (= c2-sub-range-end (sub1 chain2-length)))
         #:when (or (zero? c2-sub-range-start)
                    (eq? (word-char-a (list-ref chain2 c2-sub-range-start))
                         chain-first-a))
         #:when (or (= (sub1 chain2-length) c2-sub-range-end)
                    (eq? (word-char-z (list-ref chain2 c2-sub-range-end))
                         chain-last-z))
         (c2-sub-range-len (in-value (add1 (- c2-sub-range-end c2-sub-range-start))))
         #:when (> chain-length c2-sub-range-len)
         (c2-sub-range (in-value (take (drop chain2 c2-sub-range-start) c2-sub-range-len)))
         (new-c2 (in-value (append (take chain2 c2-sub-range-start)
                                   chain
                                   (drop chain2 (add1 c2-sub-range-end))))))      
      (cons c2-sub-range ; put the subrange back into the chains pool
            (cons new-c2 ; put the modified onto the chains pool
                  (copy-list-ignoring-indices chains chain-idx chain2-idx))))))

(define (longest-chain/constructive names #:known-max (known-max +inf.0))
  (define names-list (map symbol->word names))
  
  (define (link-chains chains)
    (let
        ((new-chains
          (for*/first
              (((chain chain-idx) (in-parallel (in-list chains) (in-naturals)))
               (new-chains
                (in-value
                 (or
                  (append-ab..bz-chains chain chain-idx chains)                                         
                  (merge-chain-into-chain-accepting-a..a-in-chain chain chain-idx chains)
                  (merge-subranges-of-chains-into-chain chain chain-idx chains))))
               #:when new-chains)
            new-chains)))
      (if new-chains (link-chains new-chains) chains)))
  
  (define (keep-trying
           (run-count 0)
           (linked-chains (link-chains (map list (shuffle names-list))))
           (previous-best null)
           (previous-best-length 0)
           (this-run-best-length #f))
    (let* ((longest-chain (argmax length linked-chains))
           (longest-chain-len (length longest-chain))
           (new-best? (< previous-best-length longest-chain-len))
           (best-length (if new-best? longest-chain-len previous-best-length))
           (best (if new-best? longest-chain previous-best)))
      (when new-best? (newline)
        (displayln (list (map word-sym longest-chain) longest-chain-len))
        (flush-output))
      (if (and new-best? (>= best-length known-max))
          (displayln "terminating: known max reached or exceeded")
          (begin
            (when (zero? (modulo (add1 run-count) 250)) (eprintf ".") (flush-output (current-error-port)))
            (if (= run-count 1000)
                (keep-trying 0 (link-chains (map list (shuffle names-list))) best best-length 0)
                (let ((sorted-linked-chains (sort linked-chains #:key length >)))
                  (keep-trying (if new-best? 0 (add1 run-count))
                               (link-chains
                                (cons (car sorted-linked-chains)
                                      (map list (shuffle (apply append (cdr sorted-linked-chains))))))
                               best best-length
                               (and this-run-best-length
                                    (if new-best? #f
                                        (if (< this-run-best-length longest-chain-len)
                                            (begin (eprintf ">~a" longest-chain-len)
                                                   (flush-output (current-error-port))
                                                   longest-chain-len)
                                            this-run-best-length))))))))))
  (keep-trying))

(time (longest-chain/constructive names-70 #:known-max 23))
(longest-chain/constructive names-646)


#lang racket
(provide names-646 names-70)
(define names-70
  '(audino bagon baltoy banette bidoof braviary bronzor carracosta charmeleon cresselia croagunk darmanitan deino emboar
    emolga exeggcute gabite girafarig gulpin haxorus heatmor heatran ivysaur jellicent jumpluff kangaskhan kricketune
    landorus ledyba loudred lumineon lunatone machamp magnezone mamoswine nosepass petilil pidgeotto pikachu pinsir
    poliwrath poochyena porygon2 porygonz registeel relicanth remoraid rufflet sableye scolipede scrafty seaking sealeo
    silcoon simisear snivy snorlax spoink starly tirtouga trapinch treecko tyrogue vigoroth vulpix wailord wartortle
    whismur wingull yamask))
; If this were true, then the 2 would be ignored, which seems a bit wrong; so wordigy the "2" -> "two"
(define Porygon2 (if #f 'Porygon2 'Porygon-two))
; note that Porygon2 is used with a comma in the list below
(define names-646
  `(Bulbasaur Ivysaur Venusaur Charmander Charmeleon Charizard Squirtle Wartortle Blastoise Caterpie Metapod Butterfree
    Weedle Kakuna Beedrill Pidgey Pidgeotto Pidgeot Rattata Raticate Spearow Fearow Ekans Arbok Pikachu Raichu Sandshrew
    Sandslash Nidoran Nidorina Nidoqueen Nidoran Nidorino Nidoking Clefairy Clefable Vulpix Ninetales Jigglypuff
    Wigglytuff Zubat Golbat Oddish Gloom Vileplume Paras Parasect Venonat Venomoth Diglett Dugtrio Meowth Persian
    Psyduck Golduck Mankey Primeape Growlithe Arcanine Poliwag Poliwhirl Poliwrath Abra Kadabra Alakazam Machop Machoke
    Machamp Bellsprout Weepinbell Victreebel Tentacool Tentacruel Geodude Graveler Golem Ponyta Rapidash Slowpoke
    Slowbro Magnemite Magneton |Farfetch'd| Doduo Dodrio Seel Dewgong Grimer Muk Shellder Cloyster Gastly Haunter Gengar
    Onix Drowzee Hypno Krabby Kingler Voltorb Electrode Exeggcute Exeggutor Cubone Marowak Hitmonlee Hitmonchan
    Lickitung Koffing Weezing Rhyhorn Rhydon Chansey Tangela Kangaskhan Horsea Seadra Goldeen Seaking Staryu Starmie
    |Mr. Mime| Scyther Jynx Electabuzz Magmar Pinsir Tauros Magikarp Gyarados Lapras Ditto Eevee Vaporeon Jolteon
    Flareon Porygon Omanyte Omastar Kabuto Kabutops Aerodactyl Snorlax Articuno Zapdos Moltres Dratini Dragonair
    Dragonite Mewtwo Mew Chikorita Bayleef Meganium Cyndaquil Quilava Typhlosion Totodile Croconaw Feraligatr Sentret
    Furret Hoothoot Noctowl Ledyba Ledian Spinarak Ariados Crobat Chinchou Lanturn Pichu Cleffa Igglybuff Togepi Togetic
    Natu Xatu Mareep Flaaffy Ampharos Bellossom Marill Azumarill Sudowoodo Politoed Hoppip Skiploom Jumpluff Aipom
    Sunkern Sunflora Yanma Wooper Quagsire Espeon Umbreon Murkrow Slowking Misdreavus Unown Wobbuffet Girafarig Pineco
    Forretress Dunsparce Gligar Steelix Snubbull Granbull Qwilfish Scizor Shuckle Heracross Sneasel Teddiursa Ursaring
    Slugma Magcargo Swinub Piloswine Corsola Remoraid Octillery Delibird Mantine Skarmory Houndour Houndoom Kingdra
    Phanpy Donphan ,Porygon2 Stantler Smeargle Tyrogue Hitmontop Smoochum Elekid Magby Miltank Blissey Raikou Entei
    Suicune Larvitar Pupitar Tyranitar Lugia Ho-Oh Celebi Treecko Grovyle Sceptile Torchic Combusken Blaziken Mudkip
    Marshtomp Swampert Poochyena Mightyena Zigzagoon Linoone Wurmple Silcoon Beautifly Cascoon Dustox Lotad Lombre
    Ludicolo Seedot Nuzleaf Shiftry Taillow Swellow Wingull Pelipper Ralts Kirlia Gardevoir Surskit Masquerain Shroomish
    Breloom Slakoth Vigoroth Slaking Nincada Ninjask Shedinja Whismur Loudred Exploud Makuhita Hariyama Azurill Nosepass
    Skitty Delcatty Sableye Mawile Aron Lairon Aggron Meditite Medicham Electrike Manectric Plusle Minun Volbeat Illumise
    Roselia Gulpin Swalot Carvanha Sharpedo Wailmer Wailord Numel Camerupt Torkoal Spoink Grumpig Spinda Trapinch Vibrava
    Flygon Cacnea Cacturne Swablu Altaria Zangoose Seviper Lunatone Solrock Barboach Whiscash Corphish Crawdaunt Baltoy
    Claydol Lileep Cradily Anorith Armaldo Feebas Milotic Castform Kecleon Shuppet Banette Duskull Dusclops Tropius
    Chimecho Absol Wynaut Snorunt Glalie Spheal Sealeo Walrein Clamperl Huntail Gorebyss Relicanth Luvdisc Bagon Shelgon
    Salamence Beldum Metang Metagross Regirock Regice Registeel Latias Latios Kyogre Groudon Rayquaza Jirachi Deoxys
    Turtwig Grotle Torterra Chimchar Monferno Infernape Piplup Prinplup Empoleon Starly Staravia Staraptor Bidoof Bibarel
    Kricketot Kricketune Shinx Luxio Luxray Budew Roserade Cranidos Rampardos Shieldon Bastiodon Burmy Wormadam Mothim
    Combee Vespiquen Pachirisu Buizel Floatzel Cherubi Cherrim Shellos Gastrodon Ambipom Drifloon Drifblim Buneary
    Lopunny Mismagius Honchkrow Glameow Purugly Chingling Stunky Skuntank Bronzor Bronzong Bonsly |Mime Jr.| Happiny
    Chatot Spiritomb Gible Gabite Garchomp Munchlax Riolu Lucario Hippopotas Hippowdon Skorupi Drapion Croagunk Toxicroak
    Carnivine Finneon Lumineon Mantyke Snover Abomasnow Weavile Magnezone Lickilicky Rhyperior Tangrowth Electivire
    Magmortar Togekiss Yanmega Leafeon Glaceon Gliscor Mamoswine Porygon-Z Gallade Probopass Dusknoir Froslass Rotom Uxie
    Mesprit Azelf Dialga Palkia Heatran Regigigas Giratina Cresselia Phione Manaphy Darkrai Shaymin Arceus Victini Snivy
    Servine Serperior Tepig Pignite Emboar Oshawott Dewott Samurott Patrat Watchog Lillipup Herdier Stoutland Purrloin
    Liepard Pansage Simisage Pansear Simisear Panpour Simipour Munna Musharna Pidove Tranquill Unfezant Blitzle Zebstrika
    Roggenrola Boldore Gigalith Woobat Swoobat Drilbur Excadrill Audino Timburr Gurdurr Conkeldurr Tympole Palpitoad
    Seismitoad Throh Sawk Sewaddle Swadloon Leavanny Venipede Whirlipede Scolipede Cottonee Whimsicott Petilil Lilligant
    Basculin Sandile Krokorok Krookodile Darumaka Darmanitan Maractus Dwebble Crustle Scraggy Scrafty Sigilyph Yamask
    Cofagrigus Tirtouga Carracosta Archen Archeops Trubbish Garbodor Zorua Zoroark Minccino Cinccino Gothita Gothorita
    Gothitelle Solosis Duosion Reuniclus Ducklett Swanna Vanillite Vanillish Vanilluxe Deerling Sawsbuck Emolga
    Karrablast Escavalier Foongus Amoonguss Frillish Jellicent Alomomola Joltik Galvantula Ferroseed Ferrothorn Klink
    Klang Klinklang Tynamo Eelektrik Eelektross Elgyem Beheeyem Litwick Lampent Chandelure Axew Fraxure Haxorus Cubchoo
    Beartic Cryogonal Shelmet Accelgor Stunfisk Mienfoo Mienshao Druddigon Golett Golurk Pawniard Bisharp Bouffalant
    Rufflet Braviary Vullaby Mandibuzz Heatmor Durant Deino Zweilous Hydreigon Larvesta Volcarona Cobalion Terrakion
    Virizion Tornadus Thundurus Reshiram Zekrom Landorus Kyurem))