[racket] Rosetta Code Minesweeper Implementation

Hello all,

Rosetta Code does not have a minesweeper implementation in Racket.  I have
created the one shown below.  Before I post it to Rosetta, I was looking
for possible feedback to shorten, make clearer, make "safer" in some way,
make more use of library functions, etc.  I would hate to give Racket a bad
name in the official show-what-your-language-can-do repository.

I believe it's not an unreasonable implementation, and I understand this
request may not sound exhilarating, so I do not expect any replies!  After
however long I feel I will simply post this solution!  With comments and a
bit of utility function groundwork it's 131 lines, 82 with that removed.

To test, run "(run)" and enter "! <row> <col>" to clear @ (row,col) or "?
<row> <col>" to assume a mine @ (row,col).

#lang racket
;turns list into list of lists each of size n
(define (group-n n l)
  (let group-n ([l l] [acc '()])
    (if (null? l)
        (reverse acc)
        (let-values ([(takes drops) (split-at l n)])
          (group-n drops (cons takes acc))))))

;small 2d vector library
;uses built-in vector with minor size stored at index 0
(define (build-vector2 maj min [f (const 0)])
  (let ([v (build-vector (add1 (* maj min))
                         (λ (n) (let-values ([(i j) (quotient/remainder
(sub1 n) min)])
                                  (f i j))))])
    (vector-set! v 0 min)
    v))
(define (vector2-maj v) (quotient (sub1 (vector-length v)) (vector2-min v)))
(define (vector2-min v) (vector-ref v 0))
(define (vector2-in-range? v i j)
  (and (<= 0 i (sub1 (vector2-maj v)))
       (<= 0 j (sub1 (vector2-min v)))))
(define (vector2-index v i j) (+ 1 j (* i (vector2-min v))))
(define (vector2-ref v i j) (vector-ref v (vector2-index v i j)))
(define (vector2-set! v i j x) (vector-set! v (vector2-index v i j) x))
(define (vector2->immutable-vector2 v) (vector->immutable-vector v))
(define (vector2->lists v) (group-n (vector2-min v) (cdr (vector->list v))))

;board uses vector2's directly, but maintaining an abstraction is nice
(define (board-ref b row col) (vector2-ref b row col))
(define (board-rows b) (vector2-maj b))
(define (board-cols b) (vector2-min b))
(define (on-board? b row col) (vector2-in-range? b row col))
(define (board->lists b) (vector2->lists b))
;run on adjacent board positions
(define-syntax-rule (for-adj b (r row) (c col) body ...)
  (for ([i '(0 0 1 1 1 -1 -1 -1)] [j '(1 -1 0 -1 1 0 -1 1)])
    (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))
(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
(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)))))

;the board is immutable even though its individual positions can mutate
their mark field
(define (init-board rows cols)
  (let ([chance (+ (/ (random) 10) 0.1)]
        ;empty board
        [b (build-vector2 rows cols (λ (r c) (pos 'hidden 0)))])
    ;loop whole board
    (for* ([row (range 0 rows)]
           [col (range 0 cols)])
      (when (< (random) chance)
        ;put a mine
        (vector2-set! b row col (pos 'hidden -1))
        ;increment adjacent mine counts unless that adjacent position is a
mine
        (for-adj b (r row) (c col)
                 (let ([p (board-ref b r c)])
                   (unless (mine? p)
                     (vector2-set! b r c (pos 'hidden (add1 (pos-n
p)))))))))
    (vector2->immutable-vector2 b)))

;only clear position if its hidden and isn't adjacent to a mine
(define (try-clear! p)
  (when (hidden0? p)
    (set-pos-mark! p 'clear)))

;the following player move functions return boolean where #f = lose, #t =
still going
;assuming can never directly lose ((void) == #t)
(define (assume! b row col) (set-pos-mark! (board-ref b row col)
'assume-mine))

;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
           (set-pos-mark! p 'clear)
           (let clear-adj ([row row] [col col])
             (for-adj b (r row) (c col)
                      ;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-let* ([(list type row col) (string-split s)]
               [row (string->number row)]
               [col (string->number col)])
    (case type
      [("?") (assume! b row col)]
      [("!") (clear! b row col)]
      [else (error "invalid move command" type)])))
(define (run)
  (let ([b (init-board 4 6)])
    (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/cd942fed/attachment.html>