Checkers Rules in Lisp

I've recently started trying to wrap my head around the beast that is Lisp. I have to say so far all the rumors are true -- just trying to program in it is enough to twist your brain into seeing problems in a whole new way.

So with that minor disclaimer, I offer you my first semi-useful chunk of Lisp code: a set of functions and macros to generate the valid checkers moves and jumps given a 2-dimensional grid representing the current position. I even exported the source from Emacs with syntax highlighting. Ooooh. Ahhhh.

(defvar board
  (make-array
   '(8 8)
   :initial-contents
   '(( 1  0  1  0  1  0  1  0)
     ( 0  1  0  1  0  1  0  1)
     ( 1  0  1  0  1  0  1  0)
     ( 0 -1  0  0  0  0  0  0)  ;; piece is out of place
     ( 0  0  0  0  0  0  0  0)  ;; to demonstrate jump
     ( 0  0  0 -1  0 -1  0 -1)
     (-1  0 -1  0 -1  0 -1  0)
     ( 0 -1  0 -1  0 -1  0 -1))))

(defvar *size* 8)
(defvar *red* 1)
(defvar *white* -1)
(defvar *empty* 0)
(defvar *red-piece* 1)
(defvar *white-piece* -1)
(defvar *red-king* 2)
(defvar *white-king* -2)

(defvar *side* *red*)

(defun get-p (x y)
  (aref board y x))

(defun set-p (x y p)
  (setf (aref board y x) p))

(defun is-my-piece (p)
  (= p *side*))

(defun is-my-king (p)
  (= p (* 2 *side*)))

(defun is-mine (p)
  (or (is-my-piece p) (is-my-king p)))

(defun is-opp (p)
  (is-mine (- p)))

(defun is-empty (p)
  (= p 0))

;; (multi-loop ((for y from 0 to 7)
;;              (for x from 0 to 7))
;;             (print (list x y)))
(defmacro multi-loop (loop-clauses body)
  (if (null loop-clauses)
      body
      (let ((clause (car loop-clauses)))
        `(loop ,@clause do
            (multi-loop ,(cdr loop-clauses) ,body)))))

;; (each-square (x y p) body)
(defun %each-square (f)
  (multi-loop
   ((for y from 0 below *size*)
    (for x from 0 below *size*))
   (let ((p (get-p x y)))
     (if (= (mod (+ x y) 2) 0)
         (funcall f x y p)))))

(defmacro each-square ((x y p) body)
  `(%each-square (lambda (,x ,y ,p) ,body)))

;; (each-square-for-side (x y p) body)
(defun %each-square-for-side (f)
  (multi-loop
   ((for y from 0 below *size*)
    (for x from 0 below *size*))
   (let ((p (get-p x y)))
     (if (and (= (mod (+ x y) 2) 0)
              (is-mine p))
         (funcall f x y p)))))

(defmacro each-square-for-side ((x y p) body)
  `(%each-square-for-side (lambda (,x ,y ,p) ,body)))

;; (each-jump-from x y (mx my nx ny) body)
(defun %each-jump-from (x y f)
  (let ((p (get-p x y)))
    (multi-loop
     ((for dy in (if (is-my-king p)
                     (list *side* (- *side*))
                     (list *side*)))
      (for dx in (list *side* (- *side*))))
     (let ((mx (+ x dx))
           (my (+ y dy))
           (nx (+ x dx dx))
           (ny (+ y dy dy)))
       (if (and (>= nx 0)
                (< nx *size*)
                (>= ny 0)
                (< ny *size*)
                (is-opp (get-p mx my))
                (is-empty (get-p nx ny)))
           (funcall f mx my nx ny))))))

(defmacro each-jump-from (x y (mx my nx ny) body)
  `(%each-jump-from ,x ,y (lambda (,mx ,my ,nx ,ny) ,body)))

;; (each-move-from x y (nx ny) body)
(defun %each-move-from (x y f)
  (let ((p (get-p x y)))
    (multi-loop
     ((for dy in (if (is-my-king p)
                     (list *side* (- *side*))
                     (list *side*)))
      (for dx in (list *side* (- *side*))))
     (let ((nx (+ x dx))
           (ny (+ y dy)))
       (if (and (>= nx 0)
                (< nx *size*)
                (>= ny 0)
                (< ny *size*)
                (is-empty (get-p nx ny)))
           (funcall f nx ny))))))

(defmacro each-move-from (x y (nx ny) body)
  `(%each-move-from ,x ,y (lambda (,nx ,ny) ,body)))

;; display all moves from this position
(each-square-for-side
 (x y p)
 (each-move-from
  x y
  (nx ny)
  (print (list x y nx ny p))))

;; display all jumps from this position
(each-square-for-side
 (x y p)
 (each-jump-from
  x y
  (mx my nx ny)
  (print (list x y mx my nx ny p))))