108 lines
3.4 KiB
Common Lisp
108 lines
3.4 KiB
Common Lisp
(defparameter *a-code* (char-code #\A))
|
|
|
|
(defparameter *words*
|
|
(as-> (uiop:read-file-line "0098_words.txt") @
|
|
(uiop:split-string @ :separator '(#\,))
|
|
(mapcar (lambda (q) (subseq q 1 (1- (length q)))) @)))
|
|
|
|
;;; Digit utilities
|
|
(defun number->digits (n)
|
|
"Returns a list of decimal digits in N (note: not in order!)"
|
|
(-> (loop for m = n then (floor m 10)
|
|
for d = (mod m 10)
|
|
while (> m 0)
|
|
collect d)
|
|
(nreverse)))
|
|
|
|
(defun digits->number (digits)
|
|
"Returns the decimal number represented by DIGITS"
|
|
(loop with result = 0
|
|
for digit in digits
|
|
do (setf result (+ (* 10 result)
|
|
digit))
|
|
finally (return result)))
|
|
|
|
;;; Word and letter anagram utilities
|
|
(defun count-letters (word)
|
|
"Counts the (upper case) letters in string WORD"
|
|
(let ((counts (make-array 26 :initial-element 0)))
|
|
(loop for character across word
|
|
do (incf (aref counts (- (char-code character) *a-code*))))
|
|
(sort (loop for i upfrom 0
|
|
for count across counts
|
|
unless (zerop count)
|
|
collect (cons (code-char (+ i *a-code*)) count))
|
|
#'char<
|
|
:key #'car)))
|
|
|
|
(defun count-digits (n)
|
|
"Counts the digits in N"
|
|
(let ((counts (make-array 10 :initial-element 0)))
|
|
(loop for d in (digits n)
|
|
do (incf (aref counts d)))
|
|
(sort (loop for i upfrom 0
|
|
for count across counts
|
|
unless (zerop count)
|
|
collect (cons i count))
|
|
#'<
|
|
:key #'car)))
|
|
|
|
(defun find-anagrams (items get-count)
|
|
"Find anagrams in COUNTS-LIST, a list of (CONS WORD LETTER-COUNTS) (or analogous) for each item"
|
|
(let ((groups (make-hash-table :test 'equal)))
|
|
(loop for item in items
|
|
for counts = (funcall get-count item)
|
|
for record = (gethash counts groups (cons nil 0))
|
|
do (incf (cdr record))
|
|
(push item (car record))
|
|
(setf (gethash counts groups) record))
|
|
(loop for counts being the hash-keys in groups using (hash-value record)
|
|
when (> (cdr record) 1)
|
|
collect (car record))))
|
|
|
|
(defun squarep (n)
|
|
(let ((root (floor (sqrt n))))
|
|
(= (* root root) n)))
|
|
|
|
(defun for-each-substitution (function letters)
|
|
(for-each-combination
|
|
(lambda (digits)
|
|
(for-each-permutation
|
|
(lambda (p)
|
|
(funcall function
|
|
(loop for digit in p
|
|
for letter in letters
|
|
collect (cons letter digit))))
|
|
digits))
|
|
'(0 1 2 3 4 5 6 7 8 9)
|
|
(length letters)))
|
|
|
|
(defun substitute-all (word substitutions)
|
|
(loop for letter across word
|
|
collect (cdr (assoc letter substitutions))))
|
|
|
|
(defun find-anagram-square (anagram)
|
|
"Finds the largest number (if any) that is part of a square anagram based off letter-to-digit conversion from a word to number, of a word anagram"
|
|
(let ((matches nil)
|
|
(letters (loop with letters = nil
|
|
for character across (first anagram)
|
|
do (pushnew character letters)
|
|
finally (return letters))))
|
|
;; Brute force
|
|
(for-each-substitution
|
|
(lambda (substitutions)
|
|
(let* ((digits (mapcar (lambda (w) (substitute-all w substitutions)) anagram))
|
|
(numbers (loop for d in digits unless (= 0 (first d)) collect (digits->number d)))
|
|
(squares (loop for number in numbers when (squarep number) collect number)))
|
|
(when (>= (length squares) 2)
|
|
(setf matches (nconc matches squares)))))
|
|
letters)
|
|
(when matches
|
|
(reduce #'max matches))))
|
|
|
|
(defun anagramic-squares ()
|
|
(let ((word-anagrams (find-anagrams *words* #'count-letters)))
|
|
(loop for anagram in word-anagrams
|
|
for number = (find-anagram-square anagram)
|
|
maximize (or number 0))))
|