;;; nim.scm
;;; Copyright (C) Robert R. Snapp 2003
;;;
;;; An implementation of the combinatorial game nim.

;; random-nim-state : number number -> list
;; Generates a random initial state for the game of nim. The first argument
;; specifies the number of heaps generated; the second, the maximum size of
;; each heap.

(define (random-nim-state heaps max-heap-size)
  (cond ((= heaps 0) '())
        (else (cons (+ (random max-heap-size) 1)
                 (random-nim-state (- heaps 1) max-heap-size)))))

;; binary-rep : number -> list
;; Decomposes the first argument into a list of powers of two.
(define (binary-rep num)
  (if (= num 0) 
    '()
    (let ((pot (largest-binary-power num)))
        (cons pot (binary-rep (- num pot))))))

;; recombine-list : list -> number
;; Recombines a list (of integers) into a number by taking the sum.
(define (recombine-list binary-list)
  (apply + binary-list))

;; recombine-state : nim-state -> lists
;; Converts a nim-state (a list of lists of numbers) into a list of numbers
;; by adding (or recombining) each list of numbers.
(define (recombine-state state)
  (map recombine-list state))

;; largest-binary-power : number -> number
;; Returns the largest power of two that is less than or equal to
;; the first argument. (Note, the first arguement must be greater
;; than or equal to one.)
(define (largest-binary-power num)
  (letrec ((pot-aux (lambda (pot)
             (cond ((> (* 2 pot) num) pot)
                   (else (pot-aux (* 2 pot)))))))
    (pot-aux 1)))

;; safe-state> : list -> boolean
;; A predicate that returns true of the list of numbers describes a
;; safe state in a game of nim. (A safe state is characterized by
;; having balanced powers of two.
(define (safe-state? lst)
  (letrec ((safe-aux? (lambda (binpower state)
             (cond ((null? state) t)
                   ((eq? binpower 1) (even? (tree-count 1 state)))
                   (else (and (even? (tree-count binpower state))
                           (safe-aux? (/ binpower 2) state)))))))
    (let* ((state (map binary-rep lst))
           (maxbinpower (apply max (map car state))))
      (safe-aux? maxbinpower state))))

;; tree-count : symbol tree -> number
;; Returns the number of times that the symbol in the first argument occurs
;; in the tree (nested list) that appears in the second argument.
(define (tree-count sym tree)
  (cond ((null? tree)   0)
        ((eq? tree sym) 1)
        ((list? tree) (+ (tree-count sym (car tree)) 
                         (tree-count sym (cdr tree))))
        (else 0)))

;; odd-bin-powers : lst -> lst
;; Returns a list of the unbalanced powers of two that occur in a 
;; given nim state.
(define (odd-bin-powers lst)
  (letrec ((odd-bp-aux (lambda (binpower state)
             (cond ((null? state) '())
                   ((eq? binpower 1) 
                    (if (odd? (tree-count 1 state))
                      '(1)
                      '()))
                   (else 
                    (if (odd? (tree-count binpower state))
                        (cons binpower (odd-bp-aux (/ binpower 2) state))
                        (odd-bp-aux (/ binpower 2) state)))))))
    (let* ((state (map binary-rep lst))
           (maxbinpower (apply max (map car state))))
      (odd-bp-aux maxbinpower state))))

;; member? : symbol lst -> boolean
;; Returns #t if the indicated symbol (first argument) appears in the list
;; in the second argument.
(define (member? sym lst)
  (cond ((null? lst) #f)
        ((eq? sym (car lst)) #t)
        (else (member? sym (cdr lst)))))

;; nim-move-find : list list -> list

(define (nim-move-find odd-bins state)
  (cond ((null? odd-bins) state)
        ((null? state) nil)
        ((member? (car odd-bins) (car state))
         (cons (nim-first-move-row odd-bins (car state))
               (cdr state)))
        (else (cons (car state) (nim-move-find odd-bins (cdr state))))))

;; nim-first-move-row : list list -> list

(define (nim-first-move-row odd-bins row)
  (cond ((null? row)
         (error 'nim-first-move-row "Row should not be null!"))
        ((null? odd-bins)
         (error 'nim-first-move-row "odd-bins should not be null."))
        ((< (car odd-bins) (car row))
         (cons (car row) (nim-first-move-row odd-bins (cdr row))))
        ((= (car odd-bins) (car row))
         (nim-next-move-row (cdr odd-bins) (cdr row)))
        (else (error 'nim-first-move-row "Data inconsistency."))))

(define (nim-next-move-row odd-bins row)
  (cond ((null? odd-bins) row)
        ((null? row) odd-bins)
        ((< (car odd-bins) (car row))
         (cons (car row) (nim-next-move-row odd-bins (cdr row))))
        ((= (car odd-bins) (car row))
         (nim-next-move-row (cdr odd-bins) (cdr row)))
        (else (cons (car odd-bins) (nim-next-move-row (cdr odd-bins) row)))))

;; nim-move : list -> list
;; Executes a rational move in an ordinary game of nim. The first argument should
;; be a simple list of intergers in which each integer represents the size of a
;; heap. A list of heap sizes, describing the outcome of the move, is returned.
;; For example, 
;;   (nim-move '(3 4 5)) -> (1 4 5)
(define (nim-move lst)
  (recombine-state 
   (nim-move-find (odd-bin-powers lst) 
                  (map binary-rep lst))))

;;; Test expressisons