;WORDLE - This package implements a solver for the well-known guessing game about five-letter words.
;Copyright (C) 2024 Prince Trippy <programmer@verisimilitudes.net>.

;This program is free software: you can redistribute it and/or modify it under the terms of the
;GNU Affero General Public License version 3 as published by the Free Software Foundation.

;This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without
;even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;See the GNU Affero General Public License for more details.

;You should have received a copy of the GNU Affero General Public License along with this program.
;If not, see <http://www.gnu.org/licenses/>.

(cl:defpackage #:wordle (:use #:common-lisp) (:import-from #:cl-user #:summarize)
               (:export #:solve #:resolve #:read-dictionary #:check-dictionary #:convert-dictionary)
  (:documentation "The WORDLE provides interactive functions which demonstrate this basic solver."))

(cl:in-package #:wordle)

(defconstant infinity 6 "This number is greater than the amount of letters allowed in a word here.")

(defun read-dictionary (pathname)
  "Read the Wordle dictionary of PATHNAME into a two-dimensional array of base characters.
The form of such a dictionary is a series of five letter words, without any separators.
An error's thrown if the dictionary's length is either zero, or not a multiple of five.
For such an error case, two interactive restarts are available: IGNORE and STORE-VALUE.
If the dictionary holds trivially invalid characters, an unrecoverable error is thrown."
  (with-open-file (stream pathname :element-type 'base-char)
    (let* ((file-length (file-length stream)) ;Five characters are wasted with any empty dictionary.
           (array (make-array (max 5 (+ file-length #0=(mod (- file-length) 5)))
                              :element-type 'base-char :fill-pointer t :initial-element #\Space)))
      (read-sequence array stream)
      (nstring-downcase array)
      (restart-case (or (and (zerop #0#) (not (zerop file-length)))
                        (error "Dictionary length ~D isn't a positive multiple of five."
                               file-length))
        (ignore () :report "Ignore the leftover letters."
          (setf (fill-pointer array) #1=(- (fill-pointer array) 5)))
        (store-value (use-value) :report "Finish the word."
          :interactive (lambda (&aux read-line (subseq #2=(subseq array #1#)))
                         (loop (format *query-io* "~&~A~%" subseq)
                               (setq read-line (read-line *query-io*))
                               (if (= 5 (length read-line)) (return (list read-line)))
                               (format *query-io*
                                       "~&The finished word must be exactly five letters long.~%")))
          (setf #2# use-value)))
      (make-array (list (/ (fill-pointer array) 5) 5) :adjustable t
                  :element-type 'base-char :displaced-to array :displaced-index-offset 0))))

(defun check-word (first second)
  "Compare the first five-letter word to the second, returning a vector holding the comparison data.
Each entry of the vector is a list of a keyword and the character, followed by any optional data.
That keyword is :NONE, indicating no presence of the character; :HERE, indicating an exact match;
:SOME, indicating the character is found elsewhere in the word; or :MISS, also indicating a miss.
The purpose of :MISS is like :NONE, but where :NONE would be inappropriate, due to other results.
A list with :HERE has one optional element, an integer meaning the exact amount of its character.
A list with :SOME includes both maximum and minimum counts in addition to an optional bit vector.
That bit vector represents the negation of all :HERE matches, which is convenient for processing."
  (let ((inspect (summarize first :size 5))
        (remove (summarize second :size 5))
        (substitute (summarize second :size 5))
        (equal (map 'simple-vector 'char= first second))
        (vector (make-array 5 :initial-element nil :adjustable nil :fill-pointer nil)))
    (dotimes (count 5) ;It's necessary to remove exact matches, to simplify the remaining algorithm.
      (if (svref equal count) (decf (gethash (char second count) remove))))
    (dotimes (count 5 vector)
      (let (some find (character (char second count)))
        (setf (svref vector count)
              (list* (cond ((not #0=(gethash character inspect)) :none)
                           ((setq find (svref equal count)) :here)
                           ;This is unique to this SUMMARIZE; it takes advantage of storing nothing.
                           ((zerop #1=(gethash character remove)) :miss)
                           ;This compares the count of the letter not missed therein with its total.
                           ((setq some (> #0# (- #2=(gethash character substitute) #1#))) :some)
                           (t :miss))
                     character
                     (cond (find (if (> #2# #0#) (list #0#)))
                           (some (let ((count (- #2# #1#)) (notevery (find t equal)))
                                   (decf #1#) ;The last bit of code in this case was so very tricky.
                                   (if (> #2# #0#)
                                       (list #0# #0#)
                                       (list* infinity (max 1 count)
                                              (if notevery ;TRACE output is nicer after this change.
                                                  (list (map 'simple-vector 'not equal))))))))))))))

(defun check-dictionary (read-dictionary &aux #-ASCII (set "abcdefghijklmnopqrstuvwxyz"))
  "Check the read dictionary to ensure it contains only lowercase English letters and nothing else."
  (check-type read-dictionary (array base-char (* 5)) "an N-by-five array of BASE-CHAR")
  (do* ((first 0 (1+ first))) ;I wanted to use DOTIMES in this, but the array dimensions can change.
       ((>= first (array-dimension read-dictionary 0)) read-dictionary)
    (loop (let ((string (ignore-errors (make-array 5 :element-type 'base-char
                                                   :displaced-to read-dictionary
                                                   :displaced-index-offset (* 5 first)))))
            (restart-case
                (if #1=(every (lambda (char)
                                #-ASCII (position char set :test 'char=)
                                #+ASCII (<= (char-code #\a) (char-code char) (char-code #\z)))
                              string)
                    (return)
                    (error "Invalid word in dictionary: ~S" string)) ;An ~S here handles all spaces.
              (ignore (&aux (last (array-dimension read-dictionary 0)) (max (max 0 (1- last))))
                :report "Ignore the invalid word."
                (setf (subseq string 0) (make-array 5 :element-type 'base-char
                                                    :displaced-to read-dictionary
                                                    :displaced-index-offset (* 5 max)))
                ;I realized in testing that I shouldn't assume the read dictionary to be adjustable.
                (setq read-dictionary (adjust-array read-dictionary (list max 5))))
              (store-value (use-value) :report "Replace the word."
                :interactive (lambda ()
                               (loop (format *query-io* "~&~A~%" string)
                                  (let ((string (read-line *query-io*)))
                                    (and (= 5 (length string)) #1# (return (list string))))
                                  (format *query-io*
                                          "~&The new word must hold only five English letters.~%")))
                (setf (subseq string 0) use-value)))))))

(defun convert-dictionary (read-dictionary)
  "Convert the dictionary to a list of BASE-STRINGs."
  (check-dictionary read-dictionary)
  (loop :for count :below (array-dimension read-dictionary 0)
        :collecting (copy-seq (make-array 5 :element-type 'base-char
                                          :displaced-to read-dictionary
                                          :displaced-index-offset (* 5 count)))))

(defun solve (read-dictionary &optional (stream *standard-output*))
  "Choose a random word from the read dictionary and solve the guessing game with those constraints.
This function uses RESOLVE internally, which provides a different, and perhaps better, interface.
SOLVE needs the dictionary in the form of a two-dimensional array as returned by READ-DICTIONARY."
  (resolve (convert-dictionary read-dictionary) stream))

(defun resolve (read-dictionary &optional (stream *standard-output*)
                &aux (count 1) (*standard-output* stream) (list (copy-list read-dictionary)))
  "Choose a random word from the read dictionary and solve the guessing game with those constraints.
RESOLVE needs the dictionary in the shape of a list of strings as returned by CONVERT-DICTIONARY.
RESOLVE works by repeatedly calling CHECK-WORD and using simple rules, to narrow down the answer."
  (cond ((zerop (length list))
         (return-from resolve (format t "~&The provided dictionary is empty.~%"))))
  (let ((random #0=(nth (random (length list)) list)))
    (format t "~&Word: ~A~%" random)
    (loop (let ((elt #0#)) ;A dictionary should allow always using the first word as the best guess.
            (format t "~&~A~%" elt)
            (if (string= random elt)
                (return (format t "~&~:(~R~) ~:[guesses were~;guess was~] needed.~%"
                                count (= 1 count))))
            (incf count) ;POSITION was removed from CHECK-WORD, to simplify this DESTRUCTURING-BIND.
            (map nil (lambda (elt position) ;The MIN and MAX were swapped after :HERE was augmented.
                       (destructuring-bind (symbol char &optional max min (map #(t t t t t))) elt
                         (setq list
                               (ecase symbol
                                 (:none (delete-if (lambda (string) (find char string :test 'char=))
                                                   list))
                                 (:here (delete-if-not
                                         #1=(lambda (string) (char= char (char string position)))
                                         (if max ;MAX means something slightly different right here.
                                             (delete-if (lambda (string)
                                                          (/= max (count char string :test 'char=)))
                                                        list)
                                             list)))
                                 (:some (delete-if-not
                                         (lambda (string &aux (rest (map 'list (lambda (char bit)
                                                                                 (if bit char))
                                                                         string map)))
                                           (<= min (count char rest) max))
                                         #2=(delete-if #1# list)))
                                 (:miss #2#)))))
                 (check-word random elt)
                 '(0 1 2 3 4))))))
.