On 06/03/2013 02:26 PM, Sean Kanaley wrote:
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.
Heh. :)
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.
You're right - this isn't obvious. It didn't occur to me that anyone
would want such a function, because a (Mutable-Array A) can be used
anywhere an (Array A) is required. But sometimes you need to protect
yourself from others...
Anyway, here's a short-ish implementation in Typed Racket:
(: array->immutable-array (All (A) ((Array A) -> (Array A))))
(define (array->immutable-array arr)
(build-array (array-shape arr)
(λ: ([js : Indexes]) (array-ref arr js))))
There are faster implementations, but they use undocumented, unsafe
functions (albeit safely).
Neil ⊥
#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!")))))
____________________
Racket Users list:
http://lists.racket-lang.org/users
____________________
Racket Users list:
http://lists.racket-lang.org/users
