(require-extension srfi-25)
(define amb-fail '*)
(define initialize-amb-fail
(lambda ()
(set! amb-fail
(lambda ()
(error "amb tree exhausted")))))
(initialize-amb-fail)
(define-macro amb
(lambda alts...
`(let ((+prev-amb-fail amb-fail))
(call/cc
(lambda (+sk)
,@(map (lambda (alt)
`(call/cc
(lambda (+fk)
(set! amb-fail
(lambda ()
(set! amb-fail +prev-amb-fail)
(+fk 'fail)))
(+sk ,alt))))
alts...)
(+prev-amb-fail))))))
(define-macro bag-of
(lambda (e)
`(let ((+prev-amb-fail amb-fail)
(+results '()))
(if (call/cc
(lambda (+k)
(set! amb-fail (lambda () (+k #f)))
(let ((+v ,e))
(set! +results (cons +v +results))
(+k #t))))
(amb-fail))
(set! amb-fail +prev-amb-fail)
(reverse +results))))
(define has-to-be
(lambda (pred)
(if (not pred) (amb))))
;;; END stuff stolen from Teach Yourself Scheme in FIXNUM Days.
;;; see http://www.ccs.neu.edu/home/dorai/t-y-scheme/t-y-scheme-Z-H-16.html
; a simple filter, as in Haskell, or as in remove-if-not in Common Lisp
(define (filter proc list)
(if (proc (car list))
(if (eq? (cdr list) '())
list
(cons (car list) (filter proc (cdr list))))
(if (eq? (cdr list) '())
'()
(filter proc (cdr list)))))
(define +grid-dimensions+ 2)
(define +grid-size+ 5)
; next-move deals with lists like '(0 -1 1 1 -1) or '(-1 0) etc.
; Each position in the list corresponds to a coordinate.
; Each number corresponds to a direction: -1 is negative, 0 is no motion,
; and 1 is positive (the definitions of "positive" and "negative" are,
; of course, arbirary).
; Calling next-move with a tile causes it to return the tile back to you.
; Once that is done, calling (amb) will come back to next-move, and continue
; as if the *next* move was returned instead.
(define (next-move tile)
(letrec ((more-dirs-available?
;; are there more combinations of directions to move in (+ or -)
;;, in the given combination of dimensions, available?
(lambda (x)
(member #t (map (lambda (n) (< n 0)) x))))
;; are there more combinations of dimensions to move in?
(more-dims-available?
(lambda (x)
(member #t (map (lambda (n) (= n 0)) x))))
;; what is the next possible combination of directions to take?
;; This function is essentially a binary incrementer.
;; for instance, '(1 1 -1 1) becomes '(-1 -1 1 1), analogous
;; to 1101 -> 0011 (lsb first). However, since you can't turn
;; around in dimensions you're not moving in at all (the zeroes),
;; those are left alone.
;; By successive recursive calls, a list that starts out as all
;; negative (and zeroes), ends up all positive (zeroes intact).
(next-dirs
(lambda (x)
(cond
((eq? tile '()) '())
((= (car x) -1) (cons 1 (cdr x)))
((= (car x) 1) (cons -1 (next-dirs (cdr x))))
((= (car x) 0) (cons (car x) (next-dirs (cdr x)))))))
;; what is the next possible combination of dimensions to move in?
;; This function is essentially a binary incrementer.
;; for instance, '(1 1 0 1) becomes '(0 0 1 1), analogous to
;; 1101 -> 0011 (lsb first).
;; Note that this function doesn't produce negative numbers..
;; the entire list is negated at once in the body of next-move
(next-dims
(lambda (x)
(cond
((eq? x '()) '())
((= (car x) 0) (cons 1 (cdr x)))
((= (car x) 1) (cons 0 (next-dims (cdr x))))))))
(amb tile
(cond
((more-dirs-available? tile) (next-move (next-dirs tile)))
((more-dims-available? tile) (next-move (map (lambda (n) (- 0 n)) (next-dims tile))))
(#t (amb))))))
(define (first-move)
(cons -1 (generate (- +grid-dimensions+ 1) 0)))
; The rule: In each dimension, you move +grid-dimensions+ paces, plus two,
; minus the number of dimensions you're moving in
; This rule was chosen because it's simple to implement (well, there's a
; simple way to implement it that eventually dawns upon you once you've
; spent a day looking for it), because it doesn't require any visualisation
; so it's easy to reason about in n dimensions, and because (of course)
; its two-dimensional case is equal to the original rules of the game
(define (apply-move move location)
(let ((num-of-dimensions (length (filter (lambda (n) (not (= 0 n))) move))))
(map
(lambda (loc mov)
(+ loc (* mov (+ 2 (- +grid-dimensions+ num-of-dimensions)))))
location
move)))
; a tile is valid if all of its coordinates are within the grid (greater or
; equal to zero but less than +grid-size+)
(define (valid-tile? tile)
(not (member #t (map (lambda (n)
(or (< n 0)
(>= n +grid-size+)))
tile))))
; this is really list-eq?
(define (coord-eq? tile1 tile2)
(not (member #f (map (lambda (n m) (eq? n m)) tile1 tile2))))
; another incrementer, this time with radix=+grid-size+ instead of 2.
; there might be a case for generalisation here...
(define (next-tile tile)
(cond
((eq? tile '()) '())
((< (car tile) (- +grid-size+ 1)) (cons (+ 1 (car tile)) (cdr tile)))
((= (car tile) (- +grid-size+ 1)) (cons 0 (next-tile (cdr tile))))))
; like the generate from C++ STL
(define (generate n value)
(if (zero? n)
'()
(cons value (generate (- n 1) value))))
(define (first-tile)
(generate +grid-dimensions+ 0))
; is every coordinate equal to +grid-size+ - 1?
(define (last-tile? tile)
(not (member #f (map (lambda (n) (eq? n (- +grid-size+ 1))) tile))))
(define (all-tiles-rec tile)
(cond
((last-tile? tile) (amb tile))
((valid-tile? tile) (amb tile (all-tiles-rec (next-tile tile))))))
(define (all-tiles)
(all-tiles-rec (first-tile)))
(define (all-moves tile)
(apply-move (next-move (first-move)) tile))
(define (unique-tile? tile visited-tiles)
(zero? (array-ref visited-tiles (apply vector tile))))
(define (solve)
(let ((visited-tiles (make-visited-tiles)))
(let loop ((n 1)
(tiles (cons (first-tile) '())))
(pretty-print (length tiles))
(pretty-print tiles)
(has-to-be (valid-tile? (car tiles)))
(has-to-be (unique-tile? (car tiles) visited-tiles))
(dynamic-wind
(array-set! visited-tiles (apply vector (car tiles)) 1)
(if (= n (expt +grid-size+ +grid-dimensions+))
tiles
(loop (+ n 1) (cons (all-moves (car tiles)) tiles)))
(array-set! visited-tiles (apply vector (car tiles)) 0)))))
(define (solve-rec n tiles)
(has-to-be (valid-tile? (car tiles)))
(has-to-be (unique-tile? (car tiles)))
(if (= n (expt +grid-size+ +grid-dimensions+))
tiles
(solve-rec (+ 1 n) (cons (all-moves (car tiles)) tiles))))
;(define (solve)
; (let ((solution (solve-rec 1 (cons (occupy-tile (all-tiles)) '()))))
; (pretty-print solution)))
(define (make-visited-tiles)
(letrec ((make-shape
(lambda (n)
(cons 0 (cons +grid-size+
(if (= n 1)
'()
(make-shape (- n 1))))))))
(make-array (apply shape (make-shape +grid-dimensions+)) 0)))
(solve)