Anagrams

p98.lisp

@@ -0,0 +1,107 @@
+(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))))

shared.lisp

@@ -19,6 +19,12 @@
 	do (setf result (append form (list result)))
 	finally (return result)))
 
+(defmacro as-> (start symbol &rest rest)
+  (loop with result = start
+	for form in rest
+	do (setf result (substitute result symbol form))
+	finally (return result)))
+
 (defmacro multf (place multiplier)
   `(setf ,place (* ,place ,multiplier)))
 
@@ -64,3 +70,24 @@
 (defun divisiblep (n divisor)
   "Returns non-NIL when N is divisible by DIVISOR"
   (= 0 (mod n divisor)))
+
+(defun remove-index (index sequence)
+  "Returns a new list that is a copy of SEQUENCE with the item at INDEX removed"
+  (loop for i upfrom 0
+	for item in sequence
+	unless (= i index) collect item))
+
+(defun for-each-permutation (f a &optional tail)
+  "Calls F on each permutation of sequence A, optionally consed onto TAIL"
+  (cond ((null a) (funcall f tail))
+	(t (loop with length = (length a)
+		 for i from 0 below length
+		 for remaining = (remove-index i a)
+		 do (for-each-permutation f remaining (cons (elt a i) tail))))))
+
+(defun for-each-combination (function list n)
+  (labels ((recurse (list n set)
+	     (cond ((zerop n) (funcall function set))
+		   (t (loop for (item . rest) on list do
+		     (recurse rest (1- n) (cons item set)))))))
+    (recurse list n nil)))