Move retraction.

chess.lisp

@@ -31,9 +31,7 @@
 
 (defclass board-pane (application-pane)
   ((board :initform (make-inital-position)
-          :accessor board)
-   (moves :initform nil
-          :accessor moves))
+          :accessor board))
   (:default-initargs
     :min-height (* *square-size* 8)
     :min-width (* *square-size* 8)
@@ -116,7 +114,7 @@
                    *images-path*))
 
 (defun load-piece (piece)
-  (make-pattern-from-bitmap-file (image-path piece)))
+  (make-pattern-from-bitmap-file (image-path piece) :format :xpm))
 
 (defun load-pieces ()
   (loop for piece in *pieces*
@@ -152,12 +150,18 @@
      (to 'square))
   (let ((board (find-board)))
     (if (check-move board from to *player-color*)
-        (psetf (board-square board from) nil
-               (board-square board to) (board-square board from)
-               *player-color* (not *player-color*))
+        (progn
+          (push (record-move board from to) (moves board))
+          (psetf (board-square board from) nil
+                 (board-square board to) (board-square board from)
+                 *player-color* (not *player-color*)))
         (format (find-pane-named *application-frame* 'interactor)
                 "Illegal move."))))
 
+(define-chess-command (com-retract :name t) ()
+  (let ((board (find-board)))
+    (retract-move board (pop (moves board)))))
+
 (defun chess ()
   (setf *images* (load-pieces))
   (run-frame-top-level (make-application-frame 'chess)))

logic.lisp

@@ -20,7 +20,9 @@
                    "br" "bn" "bb" "bq" "bk" "bp"))
 
 (defun make-inital-position ()
-  (make-array '(8 8) :initial-contents *initial-position*))
+  (list
+   (make-array '(8 8) :initial-contents *initial-position*)  ; Board
+   ()))                                ; Moves
 
 ;;; Square abstraction
 (defun square (rank file) (cons rank file))
@@ -33,13 +35,19 @@
 
 (defun board-square (board square)
   (when (valid-square-p square)
-    (aref board (rank square) (file square))))
+    (aref (car board) (rank square) (file square))))
 
 (defun (setf board-square) (value board square)
   (when (valid-square-p square)
-    (setf (aref board (rank square) (file square))
+    (setf (aref (car board) (rank square) (file square))
           value)))
 
+(defun moves (board)
+  (cadr board))
+
+(defun (setf moves) (value board)
+  (setf (cadr board) value))
+
 (defun square-keyword (square)
   "square -> :a1"
   (coerce (vector (char *letters* (rank square))
@@ -150,3 +158,11 @@
           for rank = (+ (rank from) rank+) then (+ rank rank+)
           for file = (+ (file from) file+)  then (+ file file+)
           never (board-square board (square rank file)))))
+
+(defun record-move (board from to)
+  (list from to (board-square board to)))
+
+(defun retract-move (board move)
+  (destructuring-bind (from to captured) move
+      (setf (board-square board from) (board-square board to)
+            (board-square board to) captured)))