;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Time-stamp: <2004-06-11 12:47:05>
;;;   Touched: Wed Jun 09 09:50:18 2004 +0530
;;;   Bugs-To: (enometh@net.meer)
;;;
;;;  Peg Solitaire - braindead brute-force search
;;;  (C) 2004 Madhu
;;;
(defpackage "PEGGED"
  (:use "CL")
  (:export "BOARD" "PEGS" "SOLVE" "PRINT-MOVES"
	   "POS" "CLEAR-BOARD" "MAKE-MOVE" "UNDO-MOVE"))
(in-package "PEGGED")

(defvar +grid-positions+
  #2A((nil nil       00 01 02       nil nil) ;;| 0
      (nil nil       03 04 05       nil nil) ;;| 1
      (        06 07 08 09 10 11 12        ) ;;| 2
      (        13 14 15 16 17 18 19        ) ;;| 3
      (        20 21 22 23 24 25 26        ) ;;| 4
      (nil nil       27 28 29       nil nil) ;;| 5
      (nil nil       30 31 32       nil nil)) ;| 6
  ;;-------------------------------------------+--
  #|           0  1  2  3  4  5  6             |#)

(defun peg (&rest positions)
  "=> board with pegs in POSITIONS"
  (loop with num = 0 for pos in positions do
	(setq num (dpb 1 (byte 1 pos) num))
	finally (return num)))

(defvar *print-grid* t)

(defun print-board (num &optional (stream t))
  (terpri stream)
  (when *print-grid*
    (loop initially (write-char #\Space stream) (write-char #\Space stream)
	  for col below 7 
	  do (prin1 col stream) (write-char #\Space stream)
	  finally (terpri stream)))
  (loop with i = 0 for row below 7 do
	(when *print-grid* (prin1 row stream) (write-char #\Space stream))
	(loop for col below 7 do
	      (case row
		((0 1 5 6) (case col
			     ((0 1 5 6) (write-char #\Space stream))
			     (t (write-char (if (logbitp (prog1 i(incf i)) num)
						#\O #\.) stream))))
		(t (write-char (if (logbitp (prog1 i(incf i)) num)
				   #\O #\.) stream)))
	      (write-char #\Space stream))
	(terpri stream)))

(defvar +left+
  #(nil 0 1
    nil 3 4
    nil 6 7 8 9 10 11
    nil 13 14 15 16 17 18
    nil 20 21 22 23 24 25
    nil 27 28
    nil 30 31))

(defvar +right+
  #(1 2 nil
    4 5 nil
    7 8 9 10 11 12 nil
    14 15 16 17 18 19 nil
    21 22 23 24 25 26 nil
    28 29 nil
    31 32 nil))

(defvar +up+
  #(nil nil nil
    0 1 2
    nil nil 3 4 5 nil nil
    6 7 8 9 10 11 12
    13 14 15 16 17 18 19
    22 23 24
    27 28 29))

(defvar +down+
  #(3 4 5
    8 9 10
    13 14 15 16 17 18 19
    20 21 22 23 24 25 26
    nil nil 27 28 29 nil nil
    30 31 32
    nil nil nil))

(defvar +dirs+ (list +up+ +left+ +down+ +right+))

(defun next-move (num dir pos)
  (let ((adj (aref dir pos)))
    (when (and adj (logbitp adj num))
      (let ((dst (aref dir adj)))
	(when (and dst (not (logbitp dst num)))
	  (dpb 1 (byte 1 dst)
	       (dpb 0 (byte 1 adj)
		    (dpb 0 (byte 1 pos) num))))))))

(defun next-moves (num)
  "=> list of boards possible on the next move on board NUM"
  (loop	for i below 33 if (logbitp i num)
	nconc (loop for dir in +dirs+ 
		    when (next-move num dir i)
		    collect it)))

(defvar +solution-board+ 65536)		; (peg 16)

(defun solve-peg (num &aux (stack (list (next-moves num))) (path (list num)))
  "=> sequence of boards, from +solution-board+ to the given board NUM"
  (loop for next-moves = (pop stack)
	if (null next-moves) do (pop path) ; backtrack
	else do
	(let* ((next (pop next-moves)) (choices (next-moves next)))
	  (push next path)
	  (cond ((and (= next +solution-board+) (return path)))
		(t (setq stack (nconc (and choices (list choices))
				      (list nil) ; backtrack marker
				      (and next-moves (list next-moves))
				      stack)))))
	until (endp stack)))

;;; ----------------------------------------------------------------------
;;; gratuitous game protocols & support for interactive playing
;;;

(defclass board ()
  ((board :initform 0 :type (integer 0 8589934591)) ; (peg 32)
   (moves :initform nil)))

(defmethod initialize-instance :after ((obj board) &key layout)
  (with-slots (board) obj
    (when layout
      (setf board
	    (ecase layout
	      (:cross (peg 4 8 9 10 16 23))
	      (:plus (peg 4 9 14 15 16 17 18 16 23))
	      (:fireplace (peg 0 1 2 3 4 5 8 9 10 15 17))
	      (:pyramid (peg 4 8 9 10 14 15 16 17 18 20 21 22 23 24 25 26))
	      (:uparrow (peg 1 3 4 5 7 8 9 10 11 16 23 27 28 29 30 31 32))
	      (:diamond (apply #'peg (loop for i below 33
					   if (case i
						((0 2 6 20 30 32 12 26 16) nil)
						(otherwise i)) collect it)))
	      (:solitaire (apply #'peg (loop for i below 33
					     unless (= i 16) collect i))))))))

(defmethod print-object ((board board) stream)
  (print-unreadable-object (board stream :type t :identity t)
    (with-slots (board moves) board
      (format stream "--")
      (print-board board stream))) board)

(defun pos (row col) (aref +grid-positions+ row col))

(defmethod clear-board ((board board))
  (with-slots (board moves) board
    (setf board 0 moves nil)) board)

(defmethod pegs ((board board))
  "=> ordered list of pegged positions"
  (with-slots (board) board
    (loop for i below 33 if (logbitp i board) collect i)))

(defmethod (setf pegs) (positions (board board))
  (mapcar (lambda (pos) (etypecase pos ((integer 0 32)))) positions)
  (with-slots (board) board
    (setf board (apply #'peg positions))) positions)

(defmethod make-move ((obj board) (pos integer) direction)
  (etypecase pos ((integer 0 32)))
  (with-slots (board moves) obj
    (let ((next (next-move board (ecase direction
				   (:right +right+) (:left +left+)
				   (:down +down+)   (:up +up+)) pos)))
      (and next (push board moves) (setf board next) obj))))

(defmethod undo-move ((obj board))	; undo last move
  (with-slots (board moves) obj
    (let ((last (pop moves)))
      (when last (setf board last) obj))))

(defmethod solve ((obj board))
  (with-slots (board moves) obj
    (let ((seq (solve-peg board)))
      (when seq
	(setf board (pop seq)
	      moves (nconc seq moves)) obj))))

(defmethod print-moves ((board board) &key (start 0) (end nil) (stream t))
  (with-slots (board moves) board
    (loop with steps = (reverse (cons board moves))
	  for i from 0 below (or end (length steps))
	  for num in steps when (>= i start)
	  do (format stream "~%--- step ~d ---" i) (print-board num))))

#+nil
(progn
(setq x (make-instance 'board :layout :fireplace))
(solve x)
(print-moves x)
(undo-move x)
(make-move x (pos 3 4) :right))