;;;; -*- mode:lisp; coding:utf-8 -*-
;;;;FILE:               puzzle.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;    Simulate a puzzle with n²-1 moving squares.
;;;;    (load "puzzle.lisp")
;;;;    (com.informatimago.common-lisp.puzzle:main)
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;    2004-03-13 <PJB> Corrected bugs signaled by
;;;;                     salma tariq <learningbug2004@yahoo.co.in>.
;;;;    2004-03-09 <PJB> Created.
;;;;    AGPL3
;;;;    Copyright Pascal J. Bourguignon 2012 - 2016
;;;;    This program is free software: you can redistribute it and/or modify
;;;;    it under the terms of the GNU Affero General Public License as published by
;;;;    the Free Software Foundation, either version 3 of the License, or
;;;;    (at your option) any later version.
;;;;    This program is distributed in the hope that it will be useful,
;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;    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/>
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf *readtable* (copy-readtable nil)))
   "This package simulates a puzzle with n²-1 moving squares.

    This software is in Public Domain.
    You're free to do with it as you please.")
  (:use "COMMON-LISP")
  (:export  "MAIN"))

(defclass square ()
  ;; What? A class for a mere integer?  No. We just leave to the reader
  ;; the pleasure to implement an picture-square subclass that would
  ;; display a picture part like on the real puzzle games.
  ((label :accessor label  :initform 0 :initarg :label :type integer)))

(defmethod print-object ((self square) stream)
  (prin1 (label self) stream)

(defclass puzzle ()
  ((size   :accessor size   :initform 4 :initarg :size :type (integer 2))
   (places :accessor places :initform nil
           :type (or null (simple-array (or null square) (* *))))
   (empty  :accessor empty  :initform nil :type list)))

(defgeneric get-coordinates  (puzzle relative-move))
(defgeneric get-movable-list (puzzle))
(defgeneric move-square      (puzzle x y))
(defgeneric play             (puzzle))

(defun shuffle (list)
  (let ((vector (coerce list 'vector)))
    (loop :for i :from (1- (length vector)) :downto 2
          :do (rotatef (aref vector i) (aref vector (random i))))
    (coerce vector 'list)))

(defmethod initialize-instance ((self puzzle) &rest args)
  (declare (ignore args))
  (let ((places (make-array (list (size self) (size self))
                            :element-type '(or null square)
                            :initial-element nil))
        (squares (shuffle (loop :for i :below (* (size self) (size self)) :collect i))))
    (declare (type (simple-array (or null square) (* *)) places))
    (loop :with size = (size self)
          :for i :from 0 :below size
          :do (loop :for j :from 0 :below size
                    :for square := (pop squares)
                    :if (zerop square)
                      :do (setf (empty self) (cons i j))
                      :do (setf (aref places i j) (make-instance 'square :label square))))
    (setf (places self) places)

(defmethod print-object ((self puzzle) (out stream))
  (let ((width (truncate (1+ (log (1- (* (size self) (size self))) 10)))))
    (format out "~&")
    (loop with size = (size self)
          for i from 0 below size do
            (loop for j from 0 below size do
              (if (aref (places self) i j)
                  (format out " ~VD " width (label (aref (places self) i j)))
                  (format out " ~VA " width "")))
            (format out "~%")))
  (format out "~%")

(defmethod get-coordinates ((self puzzle) relative-move)
  (block nil
    (destructuring-bind (x . y) (empty self)
      (case relative-move
        ((:u) (when (< 0 x)                (return (values (1- x) y))))
        ((:d) (when (< x (1- (size self))) (return (values (1+ x) y))))
        ((:l) (when (< 0 y)                (return (values x (1- y)))))
        ((:r) (when (< y (1- (size self))) (return (values x (1+ y)))))
         (error "Invalid relative move, must be (member :l :r :u :d).")))
      (error "Cannot move empty toward this direction."))))

(defmethod get-movable-list ((self puzzle))
   (lambda (d) (handler-case
                   (multiple-value-bind (x y) (get-coordinates self d)
                     (list (list d (aref (places self) x y))))
                 (error () nil)))
   '(:l :r :u :d)))

(defmethod move-square ((self puzzle) (x integer) (y integer))
  (when (and (<= 0 x (1- (size self)))  (<= 0 y (1- (size self))))
    (destructuring-bind (ex . ey) (empty self)
      (psetf (aref (places self) x y)   (aref (places self) ex ey)
             (aref (places self) ex ey) (aref (places self) x y))
      (setf (empty self) (cons x y)))))

(defmethod play ((self puzzle))
       (format t "~&----------------------------------------~%")
       (format t "~A" self)

       (let ((input (let ((*package* (load-time-value (find-package "COM.INFORMATIMAGO.COMMON-LISP.PUZZLE"))))
                      ;; To be able to read mere symbols (instead of keywords).
                        (format *query-io* "Number of square to move, or :help? ")
                        (finish-output *query-io*)
                        (let ((input (read *query-io*)))
                          (case input
                            ((:h :help h help)
                             (format *query-io*
                                     "Enter the number of the square to move, or one of: ~%~{~S~^ ~}~%"
                                     '(l left r right u up d down q quit exit abort)))
                            (otherwise (return input)))))))
             (movable (get-movable-list self))
             x y)
         (typecase input
            (let ((m (member input movable
                             :key (lambda (x) (label (second x))) :test (function =))))
              (if m
                    ;; (setf square (second (car m)))
                    (multiple-value-setq (x y)
                      (get-coordinates self (first (car m)))))
                    (format t "Cannot move square ~D.~%" input)
                    (go :loop)))))
                  (multiple-value-setq (x y)
                     self (case input
                            ((:l :left l left)   :l)
                            ((:r :right r right) :r)
                            ((:u :up u up)       :u)
                            ((:d :down d down)   :d)
                            ((:q :quit q quit :exit exit
                               :abort abort :break break)
                             (return-from play))
                            (otherwise input))))
                  ;; (setf square (aref (places self) x y))
              (error (err) (format t "~A~%" err) (go :loop))))
           (otherwise (format t "Invalid input.~%") (go :loop)))
         ;; (format t "Moving square ~S~%" square)
         (move-square self x y)))))

(defun main ()
  (format t "~% Size of the puzzle: ")
  (let ((input (read)))
    (typecase input
       (unless (<= 2 input 16)  (error "Cannot display such a puzzle.")))
       (error "Please choose an integer size between 2 and 16 inclusive.")))
    (play (make-instance 'puzzle :size input))))

;;;; THE END ;;;;