;;;  An interactive text-based front-end to the number puzzle
;;;

(defmacro inc-mod (place modulus)
  `(setf ,place (mod (1+ ,place) ,modulus)))

(defmacro dec-mod (place modulus)
  `(setf ,place (mod (1- ,place) ,modulus)))


(defun copy-array (src)
  (let ((dst (make-array (array-dimensions src))))
    (dotimes (i (array-total-size src))
      (setf (row-major-aref dst i) (row-major-aref src i)))
    dst))



(defun char-to-digit (ch)
  "Assumes an ASCII character encoding, or a superset of that."
  (assert (characterp ch))
  (and (digit-char-p ch)
       (- (char-code ch) (char-code #\0))))

(defparameter +puzzle-row-size+ 9)
(defparameter +puzzle-col-size+ 9)
(defparameter *puzzle-row* 0)
(defparameter *puzzle-col* 0)
(defparameter *pushed-states* '())

(defparameter *base-guess* (make-array (list +puzzle-row-size+ +puzzle-col-size+)))
(defparameter *user-guess* (make-array (list +puzzle-row-size+ +puzzle-col-size+)))
(defparameter *puzzle-solution* (make-array (list +puzzle-row-size+ +puzzle-col-size+)))
(defparameter *undo-list* '())
(defparameter *difficulty* nil)


(defgeneric initialize-interface (obj &rest remainder)
  (:documentation "Initialize the output interface."))

(defgeneric shutdown-interface (obj)
  (:documentation "Shut down the output interface."))

(defgeneric get-next-event (obj &rest remainder)
  (:documentation "Return the next event from the output interface.
Should be one of 'up, 'left, 'right, 'down, 'push, 'pop, 'reset,
'check, 'undo, 'blank, 'quit, 'refresh 'left-max 'right-max, 'help"))

(defgeneric paint-puzzle (obj)
  (:documentation "Produce the current state of the user's guess of
the puzzle on the display device."))

(defgeneric blank-interface (obj)
  (:documentation "Erase the screen for rewriting."))

(defgeneric paint-cell (obj row col &optional digit)
  (:documentation "Put the value 'digit' at coordinates (row,col).  If
digit is nil, insert whatever is the representation of an
unset/unguessed cell."))

(defgeneric move-cursor (obj &optional x y)
  (:documentation "Move to (x,y), if those are unset, use the
*puzzle-x* and *puzzle-y*."))

(defgeneric highlight-guess (obj x y num)
  (:documentation "Highlight the number at x and y, used when popping
the state to show the user what he chose previously."))

(defgeneric announce-status (obj message)
  (:documentation "Paint the given message on the display."))

(defgeneric signal-error (obj)
  (:documentation "Highlight an error status in some way.  Beep,
flash, whatever."))

(defgeneric confirm (obj message)
  (:documentation "Implement a version of y-or-n-p for the interface,
printing the message before the query."))

(defgeneric show-help (obj)
  (:documentation "Display a help message on the interface, wait for a
keypress/user interaction event before returning."))


#+(and clisp screen)
(progn
  (defclass screen-interface ()
     ((window-stream      :accessor get-stream)))

  ;; Every platform must define a make-interface function that
  ;; optionally takes the identity of the interface type to create.
  (defun make-interface (&optional interface-type)
    (declare (ignore interface-type))
    (make-instance 'screen-interface))

   (defmethod initialize-interface ((obj screen-interface) &rest unused)
     (declare (ignore unused))
     (setf (get-stream obj) (screen:make-window)))
   
   (defmethod shutdown-interface ((obj screen-interface))
     (close (get-stream obj)))

   (defmethod get-next-event ((obj screen-interface) &rest unused)
     (declare (ignore unused))
     (ext:with-keyboard 
         (let* ((keypress (read-char ext:*keyboard-input*))
                (char-slot (system::input-character-char keypress))
                (bit-slot (system::input-character-bits keypress))
                (key-slot (system::input-character-key keypress)))

           (when (and (characterp char-slot)
                      (alpha-char-p char-slot))
             (setf char-slot (char-upcase char-slot)))

           (cond ((case char-slot
                    (#\I 'up)
                    (#\J 'left)
                    (#\K 'right)
                    (#\M 'down)
                    (#\H 'help)
                    (#\P 'push)
                    (#\O 'pop)
                    (#\R 'reset)
                    (#\C 'check)
                    (#\U 'undo)
                    (#\  'blank)
                    (#\Q 'quit)))

                 ((and (characterp char-slot)
                       (digit-char-p char-slot))
                  (char-to-digit char-slot))

                 (key-slot
                  (case key-slot
                    (#\L     (and (= bit-slot 1) 'refresh))
                    (#\A     (and (= bit-slot 1) 'left-max))
                    (#\E     (and (= bit-slot 1) 'right-max))
                    (:up     'up)
                    (:left   'left)
                    (:right  'right)
                    (:down   'down)
                    (:delete 'blank)))))))


   (defmethod blank-interface ((obj screen-interface))
     (screen:clear-window (get-stream obj)))

   (defmethod paint-cell ((obj screen-interface) row col &optional digit)
     "Put the value 'digit' at coordinates (row,col).  If digit is nil,
insert whatever is the representation of an unset/unguessed cell."
     (move-cursor obj row col)
     (write-char (if digit (digit-char digit) #\-) (get-stream obj)))

   (defmethod paint-puzzle ((obj screen-interface))
     (dotimes (row +puzzle-row-size+)
       (dotimes (col +puzzle-col-size+)
         (paint-cell obj row col (aref *user-guess* row col))))
     (move-cursor obj (+ +puzzle-row-size+ 2) 3)
     (write-string (format nil "Difficulty: ~A" *difficulty*) (get-stream obj))
     (move-cursor obj))

   (defmethod move-cursor ((obj screen-interface) &optional (x *puzzle-row*) (y *puzzle-col*))
     (let ((coords (screen-coords x y)))
       (screen:set-window-cursor-position (get-stream obj) (car coords) (cadr coords))))

   (defmethod highlight-guess ((obj screen-interface) x y num)
     (let ((*puzzle-row* x)
           (*puzzle-col* y))
       (move-cursor obj)
       (screen:highlight-on (get-stream obj))
       (paint-cell obj x y num))
     (screen:highlight-off (get-stream obj))
     (move-cursor obj))


   (defmethod announce-status ((obj screen-interface) message)
     (move-cursor obj 12 4)
     (screen:clear-window-to-eot (get-stream obj))
     (write-string message (get-stream obj))
     (move-cursor obj))

   (defconstant +help-string+ "Press H for help during game~%")

   (defmethod show-help ((obj screen-interface))
     (blank-interface obj)
     (move-cursor obj 1 1)
     (write-string (format nil "
1 to 9   place value at cursor
I        move cursor upwards
J        move cursor left
K        move cursor right
M        move cursor down
ARROWS   move cursor
H        get help (this screen)
P        push state
O        pop state, and show value chosen after last push
R        reset puzzle, start over
C        check puzzle, query solution valid
U        undo operation, does not cross a push/pop boundary
SPACE    blank out a cell, undoing a guess
Q        quit the puzzle
CTRL-A   move to beginning of row
CTRL-E   move to end of row
CTRL-L   redraw screen
DEL      blank out a cell, undoing a guess

PRESS ANY KEY TO CONTINUE
") (get-stream obj))
     (ext:with-keyboard 
         (let* ((keypress (read-char ext:*keyboard-input*))
                (char-slot (system::input-character-char keypress)))
           (declare (ignore char-slot))))
     (blank-interface obj))  

   (defmethod signal-error ((obj screen-interface))
     (declare (ignore obj)))

   (defmethod confirm ((obj screen-interface) message)
     (announce-status obj message)
     (ext:with-keyboard 
         (let* ((keypress (read-char ext:*keyboard-input*))
                (char-slot (system::input-character-char keypress)))
           (and (characterp char-slot)
                (eql #\Y (char-upcase char-slot))))))
   )






#+sbcl
(progn
  (defclass screen-interface ()
     ((window-stream      :accessor get-stream)))

  (defun print-at-puzzle-coords (win row col string)
    (let ((coords (screen-coords row col)))
      (cl-ncurses::mvwprintw win (car coords) (cadr coords) string)))


  ;; My cl-ncurses package doesn't define the keypad codes when
  ;; 'keypad' is true.
  (defparameter +left-arrow+ 260)
  (defparameter +right-arrow+ 261)
  (defparameter +up-arrow+ 259)
  (defparameter +down-arrow+ 258)
  (defparameter +delete+ 330)
  
  ;; Association list to remap the special keypad codes to regular
  ;; ASCII keys
  (defparameter remap (list (cons +left-arrow+ (char-code #\J))
                            (cons +right-arrow+ (char-code #\K))
                            (cons +up-arrow+ (char-code #\I))
                            (cons +down-arrow+ (char-code #\M))
                            (cons +delete+ (char-code #\ ))))

  ;; Every platform must define a make-interface function that
  ;; optionally takes the identity of the interface type to create.
  (defun make-interface (&optional interface-type)
    (declare (ignore interface-type))
    (make-instance 'screen-interface))

   (defmethod initialize-interface ((obj screen-interface) &rest unused)
     (declare (ignore unused))
     (setf (get-stream obj) (cl-ncurses::initscr))
     (cl-ncurses::keypad (get-stream obj) 1)
     (cl-ncurses::cbreak)
     (cl-ncurses::noecho))

   (defmethod shutdown-interface ((obj screen-interface))
     (cl-ncurses::endwin))

   (defmethod get-next-event ((obj screen-interface) &rest unused)
     (declare (ignore unused))
     (let* ((keyint (cl-ncurses::wgetch (get-stream obj)))
            keychar)

       ;; cast special keypresses down to their 7-bit ASCII
       ;; equivalents, or NIL if the key pressed doesn't interest us
       (when (> keyint 127)
         (or (setf keyint (cdr (assoc keyint remap)))
             (return-from get-next-event nil)))

       (setf keychar (char-upcase (code-char keyint)))

       (cond ((digit-char-p keychar) (char-to-digit keychar))
             ((case keychar
                (#\I 'up)
                (#\J 'left)
                (#\K 'right)
                (#\M 'down)
                (#\H 'help)
                (#\P 'push)
                (#\O 'pop)
                (#\R 'reset)
                (#\C 'check)
                (#\U 'undo)
                (#\  'blank)
                (#\Q 'quit)
                (#\Page 'refresh)
                (#\Enq 'right-max)
                (#\Soh 'left-max))))))

   (defmethod blank-interface ((obj screen-interface))
     (cl-ncurses::werase (get-stream obj))
     (cl-ncurses::wrefresh (get-stream obj)))

   (defmethod paint-cell ((obj screen-interface) row col &optional digit)
     "Put the value 'digit' at coordinates (row,col).  If digit is nil,
insert whatever is the representation of an unset/unguessed cell."
     (move-cursor obj row col)
     (cl-ncurses::waddch (get-stream obj) (char-code (if digit (digit-char digit) #\-)))
     (cl-ncurses::wrefresh (get-stream obj)))

   (defmethod paint-puzzle ((obj screen-interface))
     (dotimes (row +puzzle-row-size+)
       (dotimes (col +puzzle-col-size+)
         (paint-cell obj row col (aref *user-guess* row col))))
     (print-at-puzzle-coords (get-stream obj) 
                             (+ +puzzle-row-size+ 2) 3 
                             (format nil "Difficulty: ~A" *difficulty*))
     (move-cursor obj))

   (defmethod move-cursor ((obj screen-interface) &optional (x *puzzle-row*) (y *puzzle-col*))
     (let ((coords (screen-coords x y)))
       (cl-ncurses::wmove (get-stream obj) (car coords) (cadr coords))
       (cl-ncurses::wrefresh (get-stream obj))))

   (defmethod highlight-guess ((obj screen-interface) x y num)
     (let ((*puzzle-row* x)
           (*puzzle-col* y))
       (move-cursor obj)
       (cl-ncurses::wattron (get-stream obj) cl-ncurses::WA_UNDERLINE)
       (paint-cell obj x y num))
     (cl-ncurses::wattroff (get-stream obj) cl-ncurses::WA_UNDERLINE)
     (move-cursor obj)
     (cl-ncurses::wrefresh (get-stream obj)))


   (defmethod announce-status ((obj screen-interface) message)
     (move-cursor obj 12 4)
     (cl-ncurses::wclrtobot (get-stream obj))
     (print-at-puzzle-coords (get-stream obj) 12 4 message)
     (move-cursor obj)
     (cl-ncurses::wrefresh (get-stream obj)))

   (defparameter +help-string+ "Press H for help during game~%")

   (defmethod show-help ((obj screen-interface))
     (blank-interface obj)
     (print-at-puzzle-coords (get-stream obj) 1 1 (format nil "
1 to 9   place value at cursor
I        move cursor upwards
J        move cursor left
K        move cursor right
M        move cursor down
ARROWS   move cursor
H        get help (this screen)
P        push state
O        pop state, and show value chosen after last push
R        reset puzzle, start over
C        check puzzle, query solution valid
U        undo operation, does not cross a push/pop boundary
SPACE    blank out a cell, undoing a guess
Q        quit the puzzle
CTRL-A   move to beginning of row
CTRL-E   move to end of row
CTRL-L   redraw screen
DEL      blank out a cell, undoing a guess

PRESS ANY KEY TO CONTINUE
"))
     (let ((keyint (cl-ncurses::wgetch (get-stream obj))))
           (declare (ignore keyint)))
     (blank-interface obj))

   (defmethod signal-error ((obj screen-interface))
     (declare (ignore obj)))

   (defmethod confirm ((obj screen-interface) message)
     (announce-status obj message)
     (let ((keyint (cl-ncurses::wgetch (get-stream obj))))
       (or (eql (char-code #\Y) keyint)
           (eql (char-code #\y) keyint))))
)








(defun screen-coords (row col)
  (let ((screen-row (+ row (truncate (/ row 3))))
        (screen-col (+ 3 (* 5 (+ col (truncate (/ col 3)))))))
    (list screen-row screen-col)))


(defun update-coords (action)
  (case action
    (up (dec-mod *puzzle-row* +puzzle-row-size+))
    (down (inc-mod *puzzle-row* +puzzle-row-size+))
    (left (dec-mod *puzzle-col* +puzzle-col-size+))
    (right (inc-mod *puzzle-col* +puzzle-col-size+))
    (left-max (setf *puzzle-col* 0))
    (right-max (setf *puzzle-col* (1- +puzzle-col-size+)))))

(defun assign-user-guess (number obj)
  (let ((retval nil))
    (setf (aref *user-guess* *puzzle-row* *puzzle-col*) number)
    (paint-cell obj *puzzle-row* *puzzle-col* number)
    (when number
      ;; check to see if this choice conflicts with any already made by the player
      (dotimes (i +puzzle-row-size+)
        (when (and (/= i *puzzle-row*)
                   (numberp (aref *user-guess* i *puzzle-col*))
                   (= number (aref *user-guess* i *puzzle-col*)))
          (highlight-guess obj i *puzzle-col* number)
          (setf retval t)))
      (dotimes (j +puzzle-col-size+)
        (when (and (/= j *puzzle-col*)
                   (numberp (aref *user-guess* *puzzle-row* j))
                   (= number (aref *user-guess* *puzzle-row* j)))
          (highlight-guess obj *puzzle-row* j number)
          (setf retval t)))
      (let ((colour-to-check (aref number-puzzle:*colour-array* *puzzle-row* *puzzle-col*)))
        (dotimes (i +puzzle-row-size+)
          (dotimes (j +puzzle-col-size+)
            (when (or (/= i *puzzle-row*)
                      (/= j *puzzle-col*))
              (when (and (= (aref number-puzzle:*colour-array* i j) colour-to-check)
                         (numberp (aref *user-guess* i j))
                         (= number (aref *user-guess* i j)))
                (highlight-guess obj i j number)
                (setf retval t)))))))
    retval))


(defun screen-puzzle (&optional force-medium)
  ;; Loop over puzzle generation until we find a "MEDIUM" difficulty puzzle
  (do ((diff-num nil))
      ((and diff-num
            (or (not force-medium)
                (= diff-num 1))))
    (format t "~%Generating puzzle......~%")
    (format t +help-string+)
    (number-puzzle:make-puzzle)
    (setf (values *difficulty* diff-num) (eval-diff:difficulty-string)))

  (dotimes (row +puzzle-row-size+)
    (dotimes (col +puzzle-col-size+)
      (setf (aref *puzzle-solution* row col) (number-puzzle:show-solution row col))
      (setf (aref *user-guess* row col) (number-puzzle:show-puzzle row col))
      (setf (aref *base-guess* row col) (number-puzzle:show-puzzle row col))))

  (let ((dsp (make-interface))
        need-pushed skip-repaint debug)
    (initialize-interface dsp)
    (paint-puzzle dsp)
    (move-cursor dsp)
    (do (event)
        ((eq event 'quit) (shutdown-interface dsp))
      (setf event (get-next-event dsp))
      (when (and (eq event 'quit)
                 (not (equalp *user-guess* *puzzle-solution*))
                 (not (confirm dsp "Confirm QUIT")))
        (announce-status dsp "")
        (setf event nil))

      (when debug
        (announce-status dsp (format nil "~W" event)))
      (if event
          (if (update-coords event)
              (move-cursor dsp)
              (progn 
                (cond ((and (numberp event)
                            (not (aref *base-guess* *puzzle-row* *puzzle-col*)))
                       (push (list *puzzle-row* *puzzle-col* (aref *user-guess* *puzzle-row* *puzzle-col*)) *undo-list*)
                       (setf skip-repaint (assign-user-guess event dsp))
                       (when need-pushed
                         (setf (nth 1 (car *pushed-states*)) *puzzle-row*)
                         (setf (nth 2 (car *pushed-states*)) *puzzle-col*)
                         (setf (nth 3 (car *pushed-states*)) event)
                         (setf need-pushed nil)))
                      ((eq 'blank event)
                       (if (not (aref *base-guess* *puzzle-row* *puzzle-col*))
                           (assign-user-guess nil dsp)))
                      ((and (eq 'push event)
                            (not need-pushed))
                       (push (list (copy-array *user-guess*) nil nil nil) 
                             *pushed-states*)
                       (setf *undo-list* '())
                       (setf need-pushed t))
                      ((eq 'refresh event)
                       (blank-interface dsp))
                      ((eq 'pop event)
                       (let ((popped-state (pop *pushed-states*)))
                         (when (and popped-state
                                    (not need-pushed))
                           (setf *user-guess* (car popped-state))
                           (paint-puzzle dsp)
                           (setf skip-repaint t)
                           (setf *undo-list* '())
                           (highlight-guess dsp
                                            (nth 1 popped-state)
                                            (nth 2 popped-state)
                                            (nth 3 popped-state))
                           (setf *puzzle-row* (nth 1 popped-state))
                           (setf *puzzle-col* (nth 2 popped-state))
                           (move-cursor dsp))
                         (setf need-pushed nil)))
                      ((eq 'help event)
                       (show-help dsp))
                      ((eq 'reset event)
                       (when (confirm dsp "Confirm RESET?")
                         (setf *pushed-states* '())
                         (setf *user-guess* (copy-array *base-guess*)))
                       (announce-status dsp ""))
                      ((eq 'undo event)
                       (let ((undo-me (pop *undo-list*)))
                         (when undo-me
                           (setf *puzzle-row* (car undo-me))
                           (setf *puzzle-col* (cadr undo-me))
                           (assign-user-guess (caddr undo-me) dsp))))
                      ((eq 'check event)
                       (if (equalp *user-guess* *puzzle-solution*)
                           (announce-status dsp "Solution correct")
                           (announce-status dsp "Solution NOT correct")))
                      (t
                       (setf skip-repaint t)
                       (signal-error dsp)))
                (if (not skip-repaint)
                    (paint-puzzle dsp))
                (setf skip-repaint nil)))))))