[racket] Rosetta Code Minesweeper Implementation

Thank you both for the replies.  I have incorporated all of your
suggestions.  The thin board wrapper over vector2 proved useful to quickly
switch everything over to arrays.  The program should no longer crash due
to user input aside from any kind of internal buffer issues that may or may
not be possible, which now exceeds the spec of allowing malformed input
(though bounds checking was still lacking).

I also found a few important bugs in the process, so forgive me but I shall
repost the code in its entirety.  The critical changes are the macro to
process adjacent positions, since clearing recursively seems to require not
using diagonals but summing the number of adjacent mines obviously does;
try-clear! wasn't returning the proper values to stop recursion; assume!
should be toggleable (not actually in the spec though); and some other
minor things.

It's surprising how difficult a seemingly easy task like cloning
minesweeper can be.  Ultimately this took several hours for what I thought
would be 30-60 minutes.

Also I couldn't find a way to make a mutable-array immutable with anything
resembling mutable-array->array so I left the board as mutable.

#lang racket
(require math)
;board uses arrays directly, but maintaining an abstraction is nice
(define (board-ref b row col) (array-ref b (vector row col)))
(define (board-rows b) (vector-ref (array-shape b) 0))
(define (board-cols b) (vector-ref (array-shape b) 1))
(define (on-board? b row col)
  (and (<= 0 row (sub1 (board-rows b)))
       (<= 0 col (sub1 (board-cols b)))))
(define (board->lists b) (array->list* b))
;run on adjacent board positions
(define-syntax (for-adj stx)
  (syntax-case stx ()
    [(_ b (r row) (c col) diag? body ...)
     (with-syntax ([is (if (syntax->datum #'diag?) #''(0 0 1 1 1 -1 -1 -1)
#''(0 0 1 -1))]
                   [js (if (syntax->datum #'diag?) #''(1 -1 0 -1 1 0 -1 1)
#''(1 -1 0 0))])
       #'(for ([i is] [j js])
           (let ([r (+ row i)]
                 [c (+ col j)])
             (when (on-board? b r c)
               body ...))))]))
;mark is either hidden, assume-mine, or clear
;n is int equal to # adj mines or -1 for mine
(struct pos ([mark #:mutable] n) #:transparent)
(define (mine? p) (= (pos-n p) -1))
;hidden0? is needed because only spaces with no mines in them and no mines
adjacent
;to them are cleared recursively
(define (hidden0? p)
  (and (symbol=? (pos-mark p) 'hidden)
       (zero? (pos-n p))))
(define (show-pos p)
  (match-let ([(pos m n) p])
    (case m
      [(hidden) "."]
      [(assume-mine) "?"]
      [(clear) (if (zero? n) " " (number->string n))]
      [else (error "illegal mark" m)])))
;put "|" around positions
(define (show-board b)
  (for ([row (board->lists b)])
    (displayln (format "|~a|" (string-join (map show-pos row) "|")))))

;winning = every position is either cleared or a hidden mine
(define (win? b)
  (for*/and ([r (range 0 (board-rows b))]
             [c (range 0 (board-cols b))])
    (let ([p (board-ref b r c)])
      (or (symbol=? (pos-mark p) 'clear)
          (mine? p)))))

(define (init-board rows cols)
  (let ([chance (+ (/ (random) 10) 0.1)]
        ;empty board
        [b (array->mutable-array (build-array (vector rows cols)
                                              (λ (x) (pos 'hidden 0))))])
    ;loop whole board
    (for* ([row (range 0 rows)]
           [col (range 0 cols)])
      (when (< (random) chance)
        ;put a mine
        (array-set! b (vector row col) (pos 'hidden -1))
        ;increment adjacent mine counts unless that adjacent position is a
mine
        (for-adj b (r row) (c col) #t
                 (let ([p (board-ref b r c)])
                   (unless (mine? p)
                     (array-set! b (vector r c) (pos 'hidden (add1 (pos-n
p)))))))))
    b))

;only clear position if it's not a mine
;only continue recursing when it's a hidden0?
(define (try-clear! p)
  (cond [(mine? p) #f]
        [(hidden0? p) (set-pos-mark! p 'clear) #t]
        [else (set-pos-mark! p 'clear) #f]))

;the following player move functions return boolean where #f = lose, #t =
still going
;assuming can never directly lose ((void) == #t from the set!)
;make sure to not allow overwriting an already cleared position
(define (toggle-assume! b row col)
  (let ([p (board-ref b row col)])
    (set-pos-mark! p (case (pos-mark p)
                       [(assume-mine) 'hidden]
                       [(hidden) 'assume-mine]
                       [(clear) 'clear]
                       [else (error "invalid mark" (pos-mark p))]))))

;clearing loses when the chosen position is a mine
;void = #t as far as if works, so no need to return #t
(define (clear! b row col)
  (let ([p (board-ref b row col)])
    (and (not (mine? p))
         ;not a mine, so recursively check adjacents, and maintain list of
visited positions
         ;to avoid infinite loops
         (let ([seen '()])
           ;clear the chosen position first, only continuing if it's a 0
           (when (try-clear! p)
             (let clear-adj ([row row] [col col])
               (for-adj b (r row) (c col) #f
                        ;make sure its not seen
                        (when (and (not (member (list r c) seen))
                                   (try-clear! (board-ref b r c)))
                          ;it was cleared, so loop after saving this
position as being seen
                          (set! seen (cons (list r c) seen))
                          (clear-adj r c)))))))))

(define (parse-and-do-move! b s)
  (match (string-split s)
    [(list type row col)
     (let ([row (string->number row)]
           [col (string->number col)])
       (if (on-board? b row col)
           (case type
             [("?") (toggle-assume! b row col)]
             [("!") (clear! b row col)]
             [else (parse-and-do-move! b (read-line))])
           (parse-and-do-move! b (read-line))))]
    [else (parse-and-do-move! b (read-line))]))
(define (run)
  (displayln (string-append "--- Enter one of:\n"
                            "--- \"! <row> <col>\" to clear at (row,col),
or\n"
                            "--- \"? <row> <col>\" to flag a possible mine
at (row,col).\n"))
  (let ([b (init-board 8 8)])
    (let run ()
      (show-board b)
      (display "enter move: ")
      (if (parse-and-do-move! b (read-line))
          (if (win? b) (displayln "CLEAR!") (run))
          (displayln "BOOM!")))))
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.racket-lang.org/users/archive/attachments/20130603/047e14b9/attachment-0001.html>