codepad

Language:

; word search solver

(define (make-matrix rows columns)
  (do ((m (make-vector rows)) (i 0 (+ i 1)))
      ((= i rows) m)
    (vector-set! m i (make-vector columns))))

(define (matrix-rows x) (vector-length x))

(define (matrix-cols x) (vector-length (vector-ref x 0)))

(define (matrix-ref m i j) (vector-ref (vector-ref m i) j))

(define (matrix-set! m i j x) (vector-set! (vector-ref m i) j x))

(define-syntax for
  (syntax-rules ()
    ((for (var first past step) body ...)
      (let ((ge? (if (< first past) >= <=)))
        (do ((var first (+ var step)))
            ((ge? var past))
          body ...)))
    ((for (var first past) body ...)
      (let* ((f first) (p past) (s (if (< first past) 1 -1)))
        (for (var f p s) body ...)))
    ((for (var past) body ...)
      (let* ((p past)) (for (var 0 p) body ...)))))

(define puzzle
  #( #( #\F #\Y #\Y #\H #\N #\R #\D )
     #( #\R #\L #\J #\C #\I #\N #\U )
     #( #\A #\A #\W #\A #\A #\H #\R )
     #( #\N #\T #\K #\L #\P #\N #\E )
     #( #\C #\I #\L #\F #\S #\A #\P )
     #( #\E #\O #\G #\O #\T #\P #\N )
     #( #\H #\P #\O #\L #\A #\N #\D )))

(define words '("ITALY" "HOLLAND" "POLAND" "SPAIN" "FRANCE" "JAPAN" "TOGO" "PERU"))

(define (search-list puzzle words)
  (do ((words words (cdr words)))
      ((null? words))
    (search puzzle (car words))))

(define (search puzzle word)
  (for (r 0 (matrix-rows puzzle))
    (for (c 0 (matrix-cols puzzle))
      (or (search-place puzzle word r c -1  0)
          (search-place puzzle word r c -1  1)
          (search-place puzzle word r c  0  1)
          (search-place puzzle word r c  1  1)
          (search-place puzzle word r c  1  0)
          (search-place puzzle word r c  1 -1)
          (search-place puzzle word r c  0 -1)
          (search-place puzzle word r c -1 -1)))))

(define (search-place puzzle word r c r-diff c-diff)
  (let loop ((i r) (j c) (ws (string->list word)))
    (cond ((null? ws) (found word r c r-diff c-diff))
          ((not (and (< -1 i (matrix-rows puzzle))
                     (< -1 j (matrix-cols puzzle)))) #f)
          ((char=? (car ws) (matrix-ref puzzle i j))
            (loop (+ i r-diff) (+ j c-diff) (cdr ws)))
          (else #f))))

(define (found word r c r-diff c-diff)
  (display word)
  (display " row ")
  (display (+ r 1))
  (display " column ")
  (display (+ c 1))
  (if (= r-diff 1) (display " down"))
  (if (= r-diff -1) (display " up"))
  (if (= c-diff 1) (display " right"))
  (if (= c-diff -1) (display " left"))
  (newline)
  #t)

(search-list puzzle words)

Private [?]

Run code