#!/bin/sh
#| -*- scheme -*-
exec mred -f "$0" "$@"
|#

;; Heavily hacked: Eli Barzilay: Maze is Life! (eli@barzilay.org)

;;;;;;;;;;;;;;;;; Configuration ;;;;;;;;;;;;;;;;;;

(define TILE-HW       16)  ; height/width of a tile
(define WIDTH         63)  ; number of tiles across
(define HEIGHT        44)  ; number of tiles down
(define BOMB-COUNT    644) ; number of bombs to hide
(define FLASH-REDRAW? #t)  ; flash redrawn areas
(define SHOW-LEFT?    #t)  ; show numbers of bombs left instead of absolute
(define AUTOSELECT?   #t)  ; auto-flag/uncover obvious tiles

;; Windows-size
(define TILE-HW    28)
(define WIDTH      30)
(define HEIGHT     24)
(define BOMB-COUNT 192)

(define DIGIT-COLORS
  ;; 0th is background; 8th is foreground
  (apply vector
         (map (lambda (c) (send the-color-database find-color c))
              '("LIGHT GRAY"
                "DARK GREEN" "BLUE" "RED" "PURPLE" "ORANGE" "YELLOW" "BROWN"
                "BLACK"))))

(define BG-COLOR      (vector-ref DIGIT-COLORS 0))
(define FG-COLOR      (vector-ref DIGIT-COLORS 8))
(define EXPLODE-COLOR (send the-color-database find-color "RED"))

(define BG-PEN (make-object pen% BG-COLOR 1 'solid))
(define FG-PEN (make-object pen% FG-COLOR 1 'solid))
(define THE-BRUSH
  (send the-brush-list find-or-create-brush BG-COLOR 'solid))
(define FLAG-BRUSH
  (send the-brush-list find-or-create-brush
        (make-object color% 128 64 64)
        'solid))
(define EXPLODE-BRUSH
  (send the-brush-list find-or-create-brush
        (make-object color% 255 128 96)
        'solid))
(define COVER-BRUSH
  (send the-brush-list find-or-create-brush
        (make-object color% 64 128 64)
        'solid))
(define WRONG-BRUSH
  (send the-brush-list find-or-create-brush
        (make-object color% 128 255 128)
        'solid))

(define REDRAW-BRUSH
  (send the-brush-list find-or-create-brush "YELLOW" 'solid))
(define REDRAW-PEN
  (make-object pen% FG-COLOR 1 'transparent))

(require (lib "defmacro.ss"))

(define (game)

  (define (build-vector n fcn)
    (let ((vec (make-vector n)))
      (do ((i 0 (add1 i))) ((= i n)) (vector-set! vec i (fcn i)))
      vec))

  ;;;;;;;;;;;;;;;;; Tiles ;;;;;;;;;;;;;;;;;;

  (define-struct tile
    (x y state contents
     neighbor-bombs neighbor-flags neighbor-covers neighbors)
    #:mutable)

  (define make-my-tile
    (lambda (x y)
      (make-tile x y 'covered #f #f #f #f '())))
  (define (remake-tile! t)
    (set-tile-state! t 'covered)
    (set-tile-contents! t #f)
    (set-tile-neighbor-bombs! t #f)
    (set-tile-neighbor-flags! t #f)
    (set-tile-neighbor-covers! t #f))

  (define (put-bomb! tile)
    (set-tile-contents! tile 'bomb))

  (define-macro is-bomb?
    (lambda (tile)
      `(tile-contents ,tile)))

  (define-macro is-flagged?
    (lambda (tile)
      `(eq? (tile-state ,tile) 'flagged)))

  (define-macro is-uncovered?
    (lambda (tile)
      `(eq? (tile-state ,tile) 'uncovered)))

  (define-macro is-covered?
    (lambda (tile)
      `(not (is-uncovered? ,tile))))

  ;;;;;;;;;;;;;;;;; Board Operations ;;;;;;;;;;;;;;;;;;
  ;; A board is a vector of vectors of tiles

  (define board #f) ; initialized by calling make-board!

  (define-macro map-surrounding
    (lambda (tile f)
      `(map ,f (tile-neighbors ,tile))))

  (define-macro for-each-surrounding
    (lambda (tile f)
      `(for-each ,f (tile-neighbors ,tile))))

  (define (surrounding-bombs tile)
    (apply + (map-surrounding tile (lambda (t) (if (is-bomb? t) 1 0)))))

  (define (surrounding-flags tile)
    (apply + (map-surrounding tile (lambda (t) (if (is-flagged? t) 1 0)))))

  (define (surrounding-covers tile)
    (apply + (map-surrounding tile (lambda (t) (if (is-covered? t) 1 0)))))

  (define-macro get-tile
    (lambda (x y)
      `(vector-ref (vector-ref board ,x) ,y)))

  (define-macro set-tile!
    (lambda (x y t)
      `(vector-set! (vector-ref board ,x) ,y ,t)))

  (define (update-neighbors tile new-state func redraw)
    (let ((old-state      (tile-state tile))
          (old-flags      (tile-neighbor-flags  tile))
          (old-covers     (tile-neighbor-covers tile))
          (new-flags      (surrounding-flags  tile))
          (new-covers     (surrounding-covers tile))
          (neighbor-bombs (tile-neighbor-bombs tile)))
      (unless new-state (set! new-state old-state))
      (set-tile-state! tile new-state)
      (set-tile-neighbor-flags!  tile new-flags)
      (set-tile-neighbor-covers! tile new-covers)
      (when (and func (eq? new-state 'uncovered)
                 (not (and (eq?  old-state  new-state)
                           (eqv? old-flags  new-flags)
                           (eqv? old-covers new-covers))))
        (when (and SHOW-LEFT? (not (eqv? old-flags new-flags)))
          (redraw tile))
        (cond
         ((and (not AUTOSELECT?) (> neighbor-bombs 0)) #f)
         ((= new-flags neighbor-bombs)
          (for-each-surrounding tile (lambda (t) (func t 'uncovered))))
         ((= new-covers neighbor-bombs)
          (for-each-surrounding tile (lambda (t) (func t 'flagged))))))))

  (define (set-state! tile what update break) ;; what = 'flagged / 'uncovered
    (let* ((old-state (tile-state tile))
           (new-state (case old-state ((covered) what) (else old-state))))
      (cond
       ((and (eq? new-state (if (is-bomb? tile) 'uncovered 'flagged))
             (or AUTOSELECT? (eq? new-state 'uncovered)))
        (set-tile-state! tile new-state)
        (send update draw-tile tile)
        (send update explode tile))
       ((eq? old-state new-state) #t)
       (else
        (let ((upd-func (lambda (t w) (set-state! t w update break)))
              (redraw   (lambda (t) (send update draw-tile t))))
          (set-tile-state! tile new-state)
          (redraw tile)
          (when (eq? new-state 'uncovered) (send update dec-curr-covers!))
          (when (eq? new-state 'flagged)   (send update dec-curr-bombs!))
          (send update check break)
          (set-tile-state! tile old-state)
          (update-neighbors tile new-state upd-func redraw)
          (for-each-surrounding
           tile (lambda (t) (update-neighbors t #f upd-func redraw))))))))

  (define (for-all-tiles f)
    (do ((x 0 (add1 x))) ((= x WIDTH))
      (let ((col (vector-ref board x)))
        (do ((y 0 (add1 y))) ((= y HEIGHT))
          (f (vector-ref col y))))))

  ;; Make random connections
  ;; (define (add-r x l)
  ;;   (if (null? l)
  ;;     (list x)
  ;;     (letrec ((nth-cdr
  ;;               (lambda (l n)
  ;;                 (if (zero? n) l (nth-cdr (cdr l) (sub1 n))))))
  ;;       (let* ((r (random (length l)))
  ;;              (c (nth-cdr l r))
  ;;              (y (car c)))
  ;;         (set-car! c x)
  ;;         (cons y l)))))
  (define add-r cons)

  (define (make-board!)
    (if board
      (for-all-tiles remake-tile!)
      (begin
        ;; Create a fresh board
        (set! board
              (build-vector
               WIDTH
               (lambda (i)
                 (build-vector HEIGHT (lambda (j) (make-my-tile i j))))))
        (for-all-tiles
         (lambda (t)
           (let ((x (tile-x t)) (y (tile-y t)))
             (do ((dx -1 (add1 dx))) ((> dx 1))
               (do ((dy -1 (add1 dy))) ((> dy 1))
                 (when (and (not (and (zero? dx) (zero? dy)))
                            (< -1 (+ x dx) WIDTH) (< -1 (+ y dy) HEIGHT))
                   (set-tile-neighbors! t (add-r (get-tile (+ x dx) (+ y dy))
                                                 (tile-neighbors t)))))))))))
    ;; Randomly insert bombs
    (let loop ([n BOMB-COUNT])
      (unless (zero? n)
        (let rloop ()
          (let* ([x (random WIDTH)] [y (random HEIGHT)] [t (get-tile x y)])
            (if (is-bomb? t)
              (rloop)
              (put-bomb! t))))
        (loop (sub1 n))))
    ;; Set surrounding-bomb counts for each tile
    (for-all-tiles
     (lambda (t) (set-tile-neighbor-bombs! t (surrounding-bombs t)))))

  ;;;;;;;;;;;;;;;;; Graphic Interface ;;;;;;;;;;;;;;;;;;

  ;; Make a frame:
  (define frame
    (make-object
     (class frame%
       (define/augment (on-close)
         (printf "Current Bomb Count: ~s~%" BOMB-COUNT)
         (exit))
       (super-instantiate ("Minesweeper") (style '(no-resize-border))))))

  ;; Make the row of controls at the top of the frame:
  (define panel
    (let ((p (make-object horizontal-panel% frame)))
      (send p stretchable-height #f)
      p))
  (define (make-centering-pane parent)
    (let ([p (make-object horizontal-pane% parent)])
      (send p set-alignment 'center 'center)
      p))
  (define (make-text-display label width parent)
    (let ((p (make-centering-pane parent)))
      (make-object message% label p)
      (make-object message% (make-string width #\X) p)))

  (define time-display
    (make-text-display "Time:" 4 panel))
  (define left-display
    (make-text-display "Left:" 5 panel))
  (define reset-button
    (make-object button% "Reset" (make-centering-pane panel)
                 (lambda (b e) (send board-canvas reset))))
  (define count-display
    (make-text-display "Mines/free:" 10 panel))
  (define risk-display
    (make-text-display "Risk:" 4 panel))

  ;; Most of the work is in this class, which extends the basic canvas
  ;;  class for drawing the Minesweeper board and handling clicks.
  (define board-canvas%
    (class canvas%
      (init-field frame)
      (inherit get-dc min-client-width min-client-height
               stretchable-width stretchable-height)
      (define clicking      #f) ; #t => click in progress
      (define clicking-x    0)  ; x position of click in progress
      (define clicking-y    0)  ; y position of click in progress
      (define ready?        #t) ; #t => accept clicks
      (define start-time    #f) ; time of first click
      (define elapsed-time  0)  ; seconds since first click
      (define timer         #f) ; a timer that updates elapsed-time
      (define curr-bombs    #f) ; number of bombs minus number of flags
      (define curr-covers   #f) ; number of uncovered tiles
      (define curr-unknowns #f)
      (define (set-elapsed-time! t)
        (set! elapsed-time t)
        (send time-display set-label (number->string t)))
      (define (adjust-counter)
        (send count-display set-label
              (format "~a/~a" curr-bombs curr-unknowns))
        (send risk-display set-label
              (format "~a%"
                      (if (zero? curr-unknowns)
                        "!!"
                        (/ (round (* 1000 (/ curr-bombs curr-unknowns)))
                           10.0))))
        (send left-display set-label
              (format "~a%"
                      (/ (round (* 1000 (/ curr-unknowns (* WIDTH HEIGHT))))
                         10.0))))
      (define (set-curr-bombs! c)
        (set! curr-bombs c)  (adjust-counter))
      (define (set-curr-covers! c)
        (set! curr-covers c) (adjust-counter))
      (define (stop-timer) ; stop the clock
        (when timer
          (send timer stop)
          (set! timer #f)))
      (define (start-timer) ; start the clock
        (set! start-time (current-seconds))
        (set! timer
              (make-object
               (class timer%
                 (define/override (notify)
                   (let ([e (- (current-seconds) start-time)])
                     (when (> e elapsed-time)
                       (set-elapsed-time! e))))
                 (super-instantiate ()))))
        (send timer start 100 #f)) ; check time roughly every .1 secs
      (define (end-of-game win?) ; stop the game
        (stop-timer)
        (set! ready? #f)
        (set! start-time #f)
        (unless win?
          (show-all-bombs win?))
        (send count-display set-label (if win? "Done!!!" "Boom!!!"))
        (send risk-display  set-label (if win? "Done!!!" "Boom!!!"))
        (send this focus))
      (define explode-source #f)
      (define/public (explode t) ; stop the game because the player hit a bomb
        ;; (printf ">>> ~s ~s~%" BOMB-COUNT elapsed-time)
        (when t (set! explode-source t))
        (end-of-game #f))
      (define (win) ; stop the game because the player won
        ;; (printf ">>> ~s ~s~%" BOMB-COUNT elapsed-time)
        (set! BOMB-COUNT (add1 BOMB-COUNT))
        (end-of-game #t))
      (define/public (reset) ; quit the current game and reset the board
        (stop-timer)
        (set! ready? #t)
        (set! start-time #f)
        (set-elapsed-time! 0)
        (set! curr-covers (* HEIGHT WIDTH))
        (set! curr-bombs  BOMB-COUNT)
        (set! curr-unknowns curr-covers)
        (adjust-counter)
        (make-board!)
        (draw-initial)
        (send this focus))
      (define (show-all-bombs win?) ; show bombs (after end)
        (for-all-tiles
         (lambda (t)
           (when (or (and (is-bomb? t) (not (is-flagged? t)))
                     (and (not (is-bomb? t)) (is-flagged? t)))
             (when (and (is-bomb? t) (not (is-flagged? t)))
               (set-tile-state! t (if win? 'flagged 'uncovered)))
             (draw-tile t))))
        (paint-needed))
      (define/public (check break)
        (cond ((= curr-covers BOMB-COUNT) (win) (break #f))
              ((zero? curr-bombs)
               (for-all-tiles
                (lambda (t)
                  (when (and (is-covered? t) (not (is-flagged? t)))
                    (when (is-bomb? t) (explode #f))
                    (set-state! t 'uncovered this (lambda (x) #f)))))
               (when (= curr-covers BOMB-COUNT) (win) (break #f)))
              (else #f)))
      (define/public (dec-curr-covers!)
        (set! curr-unknowns (sub1 curr-unknowns))
        (set-curr-covers!   (sub1 curr-covers)))
      (define/public (dec-curr-bombs!)
        (set! curr-unknowns (sub1 curr-unknowns))
        (set-curr-bombs!    (sub1 curr-bombs)))
      (define (do-select t flag?) ; handle a click on a tile
        (let* ([old-state (tile-state t)]
               [new-state (case old-state
                            [(covered) (if flag? 'flagged 'uncovered)]
                            [(flagged) (if flag? 'covered old-state)]
                            [else      old-state])])
          (let/ec break
            (set-state! t (if flag? 'flagged 'uncovered) this break))
          (paint-needed)))
      (define/override (on-event e) ; handle a click
        (when ready?
          (unless start-time    ; if the timer's not running, start it
            (when (send e button-down?)
              (start-timer)))
          (let* ([x (inexact->exact (floor (/ (send e get-x) TILE-HW)))]
                 [y (inexact->exact (floor (/ (send e get-y) TILE-HW)))]
                 [t (if (and (< -1 x WIDTH) (< -1 y HEIGHT))
                      (get-tile x y)
                      #f)]) ; not a tile
            (cond
             [(and clicking t (not (eq? clicking t)))
              ;; We're already in the middle of a click, and the mouse
              ;;   was moved. Paint the tile to show whether releasing the
              ;;   mouse button selects the tile.
              (let ((old clicking))
                (set! clicking #f)
                (draw-tile old #t))]
             [(and clicking t (send e button-up?))
              (set! clicking #f)
              (do-select t (send e button-up? 'right))]
             [(and clicking t)
              (set! clicking-x x)
              (set! clicking-y y)
              (unless (eq? clicking t)
                (set! clicking t)
                (draw-tile t #t))]
             [(and t (is-covered? t) (not (is-flagged? t))
                   (or (send e button-down?)
                       (and (send e dragging?)
                            (= x clicking-x)
                            (= y clicking-y))))
              ;; Start a click on a covered tile
              (set! clicking-x x)
              (set! clicking-y y)
              (unless (eq? clicking t)
                (set! clicking t)
                (draw-tile t #t))]
             [else 'ok]))))
      (define/override (on-char e)
        (let ([key (send e get-key-code)]
              [x (inexact->exact (floor (/ (send e get-x) TILE-HW)))]
              [y (inexact->exact (floor (/ (send e get-y) TILE-HW)))])
          (when (and (< x WIDTH) (< y HEIGHT)
                     (memq key (if ready? '(#\z #\x #\q) '(#\r #\q))))
            (unless start-time    ; if the timer's not running, start it
              (start-timer))
            (unless clicking
              (case key
                [(#\q) (send frame on-close)]
                [(#\z) (do-select (get-tile x y) #f)]
                [(#\x) (do-select (get-tile x y) #t)]
                [(#\r) (reset)]
                [else #f])))
          'ok))
      (define/public (draw-tile t . paint?)
        (let ((state (tile-state t))
              (x (* (tile-x t) TILE-HW)) (y (* (tile-y t) TILE-HW))
              (hilite? (eq? t clicking)))
          (set! min-x (min min-x x))
          (set! min-y (min min-y y))
          (set! max-x (max max-x (+ x TILE-HW)))
          (set! max-y (max max-y (+ y TILE-HW)))
          (let ((draw-text-tile
                 (lambda (border? str color brush)
                   (when brush (send dc set-brush brush))
                   (send dc set-pen (if border? FG-PEN BG-PEN))
                   (send dc draw-rectangle x y TILE-HW TILE-HW)
                   (when hilite?
                     (send dc draw-rectangle
                           (+ x 1) (+ y 1) (- TILE-HW 2) (- TILE-HW 2))
                     (send dc draw-rectangle
                           (+ x 2) (+ y 2) (- TILE-HW 4) (- TILE-HW 4)))
                   (when str
                     (send dc set-text-foreground (or color FG-COLOR))
                     (let-values ([(tw th d a)
                                   (send dc get-text-extent str)])
                       (send dc draw-text str
                             (+ x (/ (- TILE-HW tw) 2))
                             (+ y (/ (- TILE-HW th) 2)))))
                   (when brush (send dc set-brush THE-BRUSH)))))
            (cond
             ((and (is-bomb? t) (is-uncovered? t))
              (draw-text-tile #f "*"
                              (and (eq? explode-source t) EXPLODE-COLOR)
                              EXPLODE-BRUSH))
             ((and (not (is-bomb? t)) (is-flagged? t))
              (draw-text-tile #f "X" #f WRONG-BRUSH))
             (else
              (case state
                [(covered) (draw-text-tile #t #f #f COVER-BRUSH)]
                [(flagged) (draw-text-tile #t "O" #f FLAG-BRUSH)]
                [(uncovered)
                 (let ((bombs (if SHOW-LEFT?
                                (- (tile-neighbor-bombs t)
                                   (or (tile-neighbor-flags t) 0))
                                (tile-neighbor-bombs t))))
                   (draw-text-tile
                    #f
                    (if (zero? bombs) #f (number->string bombs))
                    (vector-ref DIGIT-COLORS bombs)
                    #f))])))))
        (when (and (not (null? paint?)) (car paint?)) (paint-needed)))
      (define dc #f)
      (define back-bmp #f)
      (define (draw-initial)
        (set! back-bmp
              (make-object bitmap% (min-client-width) (min-client-height)))
        (set! dc (make-object bitmap-dc% back-bmp))
        (send dc clear)
        ;; (for-all-tiles draw-tile) -- much faster below
        (send dc set-brush COVER-BRUSH)
        (send dc set-pen FG-PEN)
        (send dc draw-rectangle 0 0 (* WIDTH TILE-HW) (* HEIGHT TILE-HW))
        (let ((w (* WIDTH TILE-HW)) (h (* HEIGHT TILE-HW)))
          (do ((i 1 (add1 i))) ((= i (max WIDTH HEIGHT)))
            (let ((i (* i TILE-HW)))
              (when (< i w)
                (send dc draw-line i 0 i h)
                (send dc draw-line (sub1 i) 0 (sub1 i) h))
              (when (< i h)
                (send dc draw-line 0 i w i)
                (send dc draw-line 0 (sub1 i) w (sub1 i))))))
        (send dc set-brush THE-BRUSH)
        (on-paint))
      (define min-x 0)
      (define min-y 0)
      (define max-x 0)
      (define max-y 0)
      (define (paint-needed)
        (when (and (< min-x max-x) (< min-y max-y))
          (let ((real (get-dc)))
            (when FLASH-REDRAW?
              (send real set-brush REDRAW-BRUSH)
              (send real set-pen REDRAW-PEN)
              (send real draw-rectangle
                    min-x min-y (- max-x min-x) (- max-y min-y))
              (sleep 0.05))
            (send real draw-bitmap-section back-bmp
                  min-x min-y min-x min-y
                  (- max-x min-x) (- max-y min-y))))
        (set! min-x (* TILE-HW (add1 WIDTH)))
        (set! min-y (* TILE-HW (add1 HEIGHT)))
        (set! max-x 0)
        (set! max-y 0))
      (define/override (on-paint)
        (send (get-dc) draw-bitmap back-bmp 0 0)
        (set! min-x (* TILE-HW (add1 WIDTH)))
        (set! min-y (* TILE-HW (add1 HEIGHT)))
        (set! max-x 0)
        (set! max-y 0))

      (super-instantiate (frame))
      ;; Make canvas size always match the board size:
      (min-client-width (* TILE-HW WIDTH))
      (min-client-height (* TILE-HW HEIGHT))
      (stretchable-width #f)
      (stretchable-height #f)
      (reset) ; initialize the game
      (send this focus)
      (send dc set-text-background BG-COLOR)
      (send dc set-brush THE-BRUSH)))

  ;; Make the board canvas:
  (define board-canvas (make-object board-canvas% frame))

  ;; Show the frame and handle events:
  (send frame show #t)
  (yield (make-semaphore)))

(game)