Solution to the final bonus puzzle on Colossal Cue. Discussion here: http://ikuramedia.com/?p=395

cue.scm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Collossal Cue - Bonus Puzzles

; Define the map as a list of rows
(define ourmap (list
             (list '* 8 1 7 8 8 5 2 9 5 9 5)
             (list 8 5 1 1 5 6 9 4 4 5 2 1)
             (list 7 2 3 5 2 9 2 6 9 3 9 4)
             (list 9 2 5 9 8 9 5 7 7 5 9 6)
             (list 2 4 6 7 1 4 2 6 6 2 5 8)
             (list 2 8 1 5 3 8 4 9 7 5 2 3)
             (list 2 9 3 5 6 7 2 4 9 4 2 5)
             (list 6 3 1 7 8 2 3 3 6 7 9 3)
             (list 2 5 7 4 2 7 8 5 5 3 5 8)
             (list 5 2 9 8 3 6 1 4 9 5 6 3)
             (list 4 6 9 8 5 4 9 7 6 4 6 8)
             (list 2 7 7 1 9 9 7 3 7 2 2 '^)
             ))

; Utility to grab the nth element of a list
(define (objectAtIndex n list)
  (if (eq? 0 n) (car list) (objectAtIndex (- n 1) (cdr list))))

; Retrieve the basic cost at a particular position on the map
(define (costAtCoord coord themap)
  (let ((x (car coord)) (y (cdr coord)))
  (define row (objectAtIndex y themap))
  (objectAtIndex x row)))

; Give a list of valid moves from a particular position on the map
; We pay special attention to (0, 1) and (1, 0) since we don't want to go back to the home square?
(define (movesFromCoord coord themap)
  (let ( (x (car coord))
         (y (cdr coord)))
    (define row (objectAtIndex y themap))
    (cond ((eq? (+ x y) 1) (list 'e 's)) ; Right next to the * we can only go s or e
        ((and (eq? (length row) (+ 1 x)) (eq? 0 y) ) (list 's 'w)) ; Top Right
        ((and (> (length row) (+ 1 x)) (eq? 0 y) ) (if (eq? x 0) (list 's 'e) (list 's 'e 'w))) ; Top Row

        ((and (eq? (length row) (+ 1 x)) (> y 0)) (list 's 'w 'n)) ; Right Hand Side
        ((and (eq? 0  x) (> y 0)) (if (eq? (+ 1 y) (length themap)) (list 'e 'n) (list 'e 's 'n))) ; Left Hand Side

        ((and (eq? (+ 1 y) (length themap)) (> x 0)) (list 'e 'n 'w)) ; Bottom Row
        (else (list 's 'e 'n 'w)))))

; Manage the current state as a list, constructor and selectors:  
(define (make-state themap coord balance accumulator incrementer) (list themap coord balance accumulator incrementer))
(define (getCoord state) (objectAtIndex 1 state))
(define (getAccumulator state) (objectAtIndex 3 state))
(define (getBalance state) (objectAtIndex 2 state))
(define (getMap state) (objectAtIndex 0 state))
(define (getIncrementer state) (objectAtIndex 4 state))
(define (getX state) (car (getCoord state)))
(define (getY state) (cdr (getCoord state)))

; This is how we start, the final 5 coin balance has been deducted from the start balance, and our goal is to reach zero
; The Trolls inflate their prices by 1 on each move so our accumulator starts at 0 and our incrementer is 1
(define start-state (make-state ourmap (cons 0 0) 439 0 1))

; Execute a particular move to transition from state to state
; If we know we can't reach the goal from the state then we return 'fail
; If we've reached the goal we return 'goal
; Otherwise we return the new state



(define (distance-from-coord from-coord to-coord)
  (+ (abs (- (car to-coord) (car from-coord))) (abs (- (cdr to-coord) (cdr from-coord)))))

(define (move direction state)
  (define x (getX state))
  (define y (getY state))
  (let ((accumulator (getAccumulator state))
        (increment (getIncrementer state))
        (balance (getBalance state))
        (themap (getMap state))

        (new-coord (cond ((eq? 'n direction) (cons x (- y 1)))
                          ((eq? 's direction) (cons x (+ y 1)))
                          ((eq? 'e direction) (cons (+ x 1) y))
                          ((eq? 'w direction) (cons (- x 1) y))))
        )
  (cond ((> (* accumulator (distance-from-coord new-coord (cons 11 11))) balance) 'fail)   ; If we're too far from the goal, and not enough balance left to get there.
        ((and (eq? 0 balance) (eq? (costAtCoord new-coord themap) '^)) 'goal) ; Found the Goal with exactly zero left
        ((and (< 0 balance) (eq? (costAtCoord new-coord themap) '^)) 'fail)   ; Ran out of Money
        (else (make-state themap
                          new-coord
                          (- balance (+ (costAtCoord  new-coord themap) accumulator))
                          (+ increment accumulator)
                          increment)))))

; Utility to apply a sequence of moves to a state
(define (apply-moves list state)
  (if (pair? list) (moves (cdr list) (move (car list) state)) state))

; SICP Utility to filter a list
(define (filter predicate list)
  (if (pair? list)
      (if (predicate (car list)) 
          (cons (car list) (filter predicate (cdr list))) 
          (filter predicate (cdr list)))
      list))

; SICP Flatmap utility
 (define (accumulate op initial sequence)
     (if (null? sequence)
         initial
         (op (car sequence)
             (accumulate op initial (cdr sequence)))))

(define (flatmap proc seq)
      (accumulate append nil (map proc seq)))

; Find all the possible next states which aren't failures
(define (nextStates movesSoFar state)
  (let ((nextMoves (movesFromCoord (getCoord state) (getMap state))))
   (filter (lambda (x) (not (eq? 'fail (cdr x)))) (map (lambda (x) (cons (append movesSoFar (list x)) (move x state))) nextMoves))))

; Show our answers before the exhaustive search is complete - there might be multiple solutions
(define (displayReturn y) ((lambda (x) (display x) x) y))
(define (noDisplayReturn y) y)

; Recursively find solutions from a particular state, keeping track of the moves taken to get to that state
(define (solutionsFromHere movesSoFar state)
  (let ((next-possible-states (nextStates movesSoFar state)))
    (let ((solutions (filter (lambda (x) (eq? 'goal (cdr x))) next-possible-states)))
      (if (pair? solutions)
          (noDisplayReturn (map car solutions))
          (if (not (pair? next-possible-states)) '() 
              (flatmap (lambda (x) (solutionsFromHere (car x) (cdr x))) next-possible-states)
                                                    )))))

; Start point to find all solution
(define (go) (solutionsFromHere '() start-state))