Browse code
feat(wordle): add Wordle utilities
Edward authored on 25/01/2022 07:50:53Showing 1 changed files
| 1 | 1 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,73 @@ |
| 1 |
+(defpackage :fwoar.lisp-sandbox.wordle |
|
| 2 |
+ (:use :cl ) |
|
| 3 |
+ (:export )) |
|
| 4 |
+(in-package :fwoar.lisp-sandbox.wordle) |
|
| 5 |
+ |
|
| 6 |
+(defmacro define-printer ((class) &rest accessors) |
|
| 7 |
+ `(defmethod print-object ((o ,class) s) |
|
| 8 |
+ (format s "#<~a ~@{~s~}>"
|
|
| 9 |
+ (class-name (class-of o)) |
|
| 10 |
+ ,@(mapcar (lambda (it) |
|
| 11 |
+ `(,it o)) |
|
| 12 |
+ accessors)))) |
|
| 13 |
+ |
|
| 14 |
+(fw.lu:defclass+ guess-score () |
|
| 15 |
+ ((%c :reader guess-char :initarg :guess-char))) |
|
| 16 |
+(define-printer (guess-score) guess-char) |
|
| 17 |
+(fw.lu:defclass+ miss ((guess-score (guess-char))) ()) |
|
| 18 |
+(fw.lu:defclass+ exac ((guess-score (guess-char))) ()) |
|
| 19 |
+(fw.lu:defclass+ misp ((guess-score (guess-char))) ()) |
|
| 20 |
+ |
|
| 21 |
+(defun wordle-match (answer guess) |
|
| 22 |
+ (let* ((exact-matches (remove-if 'null (map 'list (lambda (a b) (when (char-equal a b) a)) |
|
| 23 |
+ answer guess))) |
|
| 24 |
+ (wrong-spot (set-difference (intersection (coerce answer 'list) |
|
| 25 |
+ (coerce guess 'list) |
|
| 26 |
+ :test 'char-equal) |
|
| 27 |
+ exact-matches |
|
| 28 |
+ :test 'char-equal))) |
|
| 29 |
+ (coerce (loop for g across guess |
|
| 30 |
+ for a across answer |
|
| 31 |
+ collect (cond |
|
| 32 |
+ ((char-equal g a) (exac g)) |
|
| 33 |
+ ((member g wrong-spot :test 'char-equal) (misp g)) |
|
| 34 |
+ (t (miss g)))) |
|
| 35 |
+ 'vector))) |
|
| 36 |
+ |
|
| 37 |
+(defun show-game (answer guesses) |
|
| 38 |
+ (loop for guess in guesses |
|
| 39 |
+ collect (wordle-match answer guess))) |
|
| 40 |
+ |
|
| 41 |
+(defun get-five-letter-words () |
|
| 42 |
+ (with-open-file (s "/usr/share/dict/words") |
|
| 43 |
+ (loop for line = (read-line s nil) |
|
| 44 |
+ while line |
|
| 45 |
+ when (= (length line) 5) |
|
| 46 |
+ collect line))) |
|
| 47 |
+ |
|
| 48 |
+(defun matches-pattern (word pattern) |
|
| 49 |
+ (loop for w across word |
|
| 50 |
+ for p across pattern |
|
| 51 |
+ always (if (alpha-char-p p) |
|
| 52 |
+ (char-equal w p) |
|
| 53 |
+ t))) |
|
| 54 |
+ |
|
| 55 |
+(defun has-all-chars (word present-chars) |
|
| 56 |
+ (every (lambda (c) |
|
| 57 |
+ (position c word :test 'char-equal)) |
|
| 58 |
+ present-chars)) |
|
| 59 |
+ |
|
| 60 |
+(defun has-no-chars (word present-chars) |
|
| 61 |
+ (not (some (lambda (c) |
|
| 62 |
+ (position c word :test 'char-equal)) |
|
| 63 |
+ present-chars))) |
|
| 64 |
+ |
|
| 65 |
+(defun search-words (wordlist pattern anti-patterns present-chars absent-chars) |
|
| 66 |
+ (loop for word in wordlist |
|
| 67 |
+ when (and (matches-pattern word pattern) |
|
| 68 |
+ (not (some (lambda (anti-pattern) |
|
| 69 |
+ (matches-pattern word anti-pattern)) |
|
| 70 |
+ anti-patterns)) |
|
| 71 |
+ (has-all-chars word present-chars) |
|
| 72 |
+ (has-no-chars word absent-chars)) |
|
| 73 |
+ collect word)) |