Untitled

(define total-rows 8)
(define total-cols 8)

;a row-col pair
(define loc-row car)
(define loc-col cdr)
(define mkloc cons)

(define (oob? loc)
  (define row (loc-row loc))
  (define col (loc-col loc))
  (or (< row 0) (< col 0)
      (>= row total-rows) (>= col total-cols)))

;boards
(define (make-board)
  (let ((ret (make-vector total-rows)))
    (define (loop i)
      (if (= i total-rows)
	  ret
	  (begin
	    (vector-set! ret i (make-vector total-cols -1))
	    (loop (+ i 1)))))
    (loop 0)))

(define (get-value board row col)
  (vector-ref (vector-ref board row) col))

(define (set-value board row col val)
  (vector-set! (vector-ref board row) col val))

(define (set-value2 board loc val)
  (vector-set! (vector-ref board (loc-row loc))
	       (loc-col loc) val))

(define (get-value2 board loc)
  (vector-ref (vector-ref board (loc-row loc))
	      (loc-col loc)))

(define (print-board board)
  (define (lead2 val)
    (if (and (< val 10) (> val -1))
	(begin (display "0") (display val))
	(display val)))
  (define (loop i j)
    (cond ((>= i total-rows) 'okay)
	  ((>= j total-cols) 
	   (newline)
	   (loop (+ i 1) 0))
	  (else
	   (lead2 (get-value board i j))
	   (display " ")
	   (loop i (+ j 1)))))
  (loop 0 0))

;goes through each element of board
;applies procedure
(define (board-iter board proc)
  (define (loop i j)
    (cond ((>= i total-rows) 'okay)
	  ((>= j total-cols) 
	   (loop (+ i 1) 0))
	  (else
	   (proc i j (get-value board i j))
	   (loop i (+ j 1)))))
  (loop 0 0))

(define (board-copy oldboard)
  (define newboard (make-board))
  (board-iter 
   oldboard
   (lambda (i j value) (set-value newboard i j value)))
  newboard)

(define (move-list board loc)
  (define row (loc-row loc))
  (define col (loc-col loc))
  (define baselist
    (list (mkloc (- row 1) (- col 2)) (mkloc (- row 1) (+ col 2))
	  (mkloc (- row 2) (- col 1)) (mkloc (- row 2) (+ col 1))
	  (mkloc (+ row 1) (- col 2)) (mkloc (+ row 1) (+ col 2))
	  (mkloc (+ row 2) (- col 1)) (mkloc (+ row 2) (+ col 1))))
  (filter 
   (lambda (x) (= -1 (get-value board (loc-row x) (loc-col x))))
   (filter (lambda (x) (not (oob? x))) baselist)))

;---reorder the list so low-access ones comes first
;quicksort library modified to sort by first element of sub-pair
;this is not expected to be understood
(define (pivot l)
  (cond ((null? l) 'done)
	((null? (cdr l)) 'done)
        ((<= (caar l) (caadr l)) (pivot (cdr l)))
	(#t (caar l))))

(define (partition piv l p1 p2)
  (if (null? l) (list p1 p2)
     (if (< (caar l) piv) (partition piv (cdr l) (cons (car l) p1) p2)
	 (partition piv (cdr l) p1 (cons (car l) p2)))))

(define (quicksort l)
 (let ((piv (pivot l)))
   (if (equal? piv 'done) l
     (let ((parts (partition piv l () ())))
       (append (quicksort (car parts)) 
               (quicksort (cadr parts)))))))

;actual thing
(define (prioritize-access access move-list)
  (map cdr (quicksort (map (lambda (x) 
			     (cons (get-value2 access x) x)) 
			   move-list))))

;initialize access list
(define (make-access)
  (define ref-board (make-board))
  (define access (make-board))
  (board-iter
   ref-board
   (lambda (i j value) 
     (set-value access i j
		(length (move-list ref-board (mkloc i j))))))
  access)

(define dec-access! ;1 less move for cell sthat can go here
  (let ((blank-board (make-board)))
    (lambda (access loc)
      (define (loop lst)
	(if (null? lst) 
	    'okay
	    (begin
	      (set-value2 access (car lst)
			  (- (get-value2 access (car lst)) 1))
	      (loop (cdr lst)))))
      (loop (move-list blank-board loc)))))
;---

(define (complete? mc)
  (= (* total-rows total-cols) (+ mc 1)))

(define (kt startloc)
  (define (first-correct board access movelist mc)
    (if (empty? movelist)
	#f
	(let ((ret (kti (board-copy board) (board-copy access) (car movelist) (+ mc 1))))
	  (if ret ret (first-correct board access (cdr movelist) mc)))))
  (define (kti board access cloc mc)
    (set-value2 board cloc mc)
    (dec-access! access cloc) ;decrement access
    (if (complete? mc)
	board
	(first-correct board access 
		       (prioritize-access 
			access (move-list board cloc)) mc)))
  (kti (make-board) (make-access) startloc 0))