おおむね完成

Makefile

@@ -0,0 +1,2 @@
+mine: 
+	sbcl --script make-mine-command.lisp

README

@@ -0,0 +1,19 @@
+[概要]
+・端末上で動作するマインスイーパー
+・CommonLisp (SBCLのみ)
+
+[バージョン]
+・0.0.1
+
+[使い方]
+・REPLから
+   $ cd mine-0.0.1
+   $ sbcl
+   > (require :asdf)
+   > (asdf:load-system :mine)
+   > (mine:game WIDTH HEIGHT BOMB_COUNT)
+
+・コマンドから
+   $ cd mine-0.0.1
+   $ make
+   $ ./mine WIDTH HEIGHT BOMB_COUNT

console.lisp

@@ -43,6 +43,7 @@
 
 (defun cfmakeraw ()
   (let ((termios (sb-posix::allocate-alien-termios)))
+
     (%cfmakeraw termios)
     (unwind-protect
         (sb-posix::alien-to-termios termios)
@@ -70,25 +71,30 @@
 
 (defun move (direction &optional (delta 1))
   (declare (direction direction))
-  (format "~a~d~a" +ESC+ delta
-          (ecase direction
-            (:up    "A")
-            (:down  "B")
-            (:left  "C")
-            (:right "D"))))
+  (when (plusp delta)
+    (format "~a~d~a" +ESC+ delta
+            (ecase direction
+              (:up    "A")
+              (:down  "B")
+              (:left  "D")
+              (:right "C")))))
 
 (defun clear (&key line)
   (if line
       (format "~a2K" +ESC+)
     (format "~a2J" +ESC+)))
 
 (defun set-pos (x y)
-  (format "~s~d;~dH" +ESC+ x y))
+  (format "~a~d;~dH" +ESC+ y x))
 
 (defmacro with-raw-mode (&body body)
   (let ((old (gensym)))
-    `(let ((,old (sb-posix:tcgetattr +STDIN_FD+)))
-       (sb-posix:tcsetattr +STDIN_FD+ sb-posix:tcsanow (cfmakeraw))
-       (unwind-protect
-           (locally ,@body)
-         (sb-posix:tcsetattr +STDIN_FD+ sb-posix:tcsanow ,old)))))
+    `(locally
+      (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
+      (let ((,old (sb-posix:tcgetattr +STDIN_FD+)))
+        (sb-posix:tcsetattr +STDIN_FD+ sb-posix:tcsanow (cfmakeraw))
+        (unwind-protect
+            (locally 
+             (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
+             ,@body)
+          (sb-posix:tcsetattr +STDIN_FD+ sb-posix:tcsanow ,old))))))

game.lisp

@@ -1,5 +1,6 @@
 (defpackage game
   (:use :common-lisp)
+  (:import-from :mine shuffle)
   (:export init-game
            board-width
            board-height
@@ -41,13 +42,6 @@
 (defmacro cell (board x y)
   `(aref ,board ,y ,x))
 
-(defun shuffle (list &aux (ary (coerce list 'vector)) (size (length ary)))
-  (loop REPEAT 2 DO
-    (loop FOR i FROM 0 BELOW size DO
-      (rotatef (aref ary i) (aref ary (random size)))))
-  (coerce ary 'list))
-
-
 ;;;;;;;;;;;;;;;;;;;;;;
 ;;; exported functions
 (defun init-game (width height)
@@ -82,18 +76,21 @@
   (assert (< 0 bomb-count (- (board-size game) 9)))
 
   (let* ((excludes `((,init-x ,init-y) . ,(surrounding-cells game init-x init-y)))
-         (bombs (subseq (shuffle (loop FOR cell FROM 0 BELOW (board-size game) 
-                                       UNLESS (find cell excludes)
-                                       COLLECT cell))
+         (bombs (subseq (shuffle (loop FOR x FROM 0 BELOW (board-width game)
+                                       APPEND
+                                       (loop FOR y FROM 0 BELOW (board-height game)
+                                             FOR pos = `(,x ,y)
+                                             UNLESS (find pos excludes :test #'equal)
+                                             COLLECT pos)))
                         0 bomb-count)))
-    (dolist (bomb bombs)
-      (setf (row-major-aref (game-board game) bomb) :bomb))
+    (loop FOR (x y) IN bombs DO
+      (setf (cell (game-board game) x y) :bomb)))
 
-    (each (cell state :x x :y y) game
-      (unless (eq cell :bomb)
-        (setf cell (count :bomb (surrounding-cells game x y) 
-                          :key (lambda (pos) 
-                                 (cell (game-board game) (first pos) (second pos))))))))
+  (each (cell state :x x :y y) game
+    (unless (eq cell :bomb)
+      (setf cell (count :bomb (surrounding-cells game x y) 
+                        :key (lambda (pos) 
+                               (cell (game-board game) (first pos) (second pos)))))))
   (open-cell game init-x init-y))
 
 (defun open-surrounding-cells (game x y)
@@ -141,7 +138,7 @@
   (each (cell state) game
     (when (and (eq cell :bomb)
                (eq state :open))
-      (return-from finish? (values t :bomb))))
+      (return-from finish? (values t nil))))
 
   (each (cell state) game
     (when (eq state :mask)
@@ -150,4 +147,4 @@
   (when (/= (bomb-count game) (flag-count game))
     (return-from finish? (values nil nil)))
 
-  (values t :clear))
+  (values t t))

make-mine-command.lisp

@@ -0,0 +1,3 @@
+(require :asdf) 
+(asdf:load-system :mine) 
+(mine:make-mine-command)

mine.asd

@@ -6,8 +6,10 @@
   :author "Takeru Ohta"
   :description "A console based mine-sweeper"
 
+  :depends-on (:sb-posix)
   :serial t
   :components ((:file "package")
+               (:file "util")
                (:file "console")
                (:file "game")
                (:file "mine")))

mine.lisp

@@ -1,9 +1,181 @@
 (in-package :mine)
 
+(defconstant +TOP+ 2)
+(defconstant +LEFT+ 2)
+
+;;;;;;;;;;;
+;;; structs
+(defstruct state
+  (pos-x 0 :type fixnum)
+  (pos-y 0 :type fixnum)
+  (beg-time (get-internal-real-time) :type fixnum)
+  (bomb-count 0 :type fixnum))
+
+;;;;;;;;;;;;;;;;;;;;;;
+;;; internal functions
+(defun show-board (game)
+  (console:set-pos +LEFT+ +TOP+)
+
+  (game:each (cell state :eol-form (progn (console:newline)
+                                          (console:move :right (1- +LEFT+)))) game
+    (console:format "~a "
+                    (case state
+                          (:mask "#")
+                          (:flag (console:style "!" :color :red :bold t))
+                          (:open (case cell
+                                   (:bomb     (console:style "*" :color :yellow :bold t))
+                                   (0         "_")
+                                   (otherwise cell)))))))
+
+(defun elapsed-time (state)
+  (let ((secs (round (- (get-internal-real-time) (state-beg-time state)) 
+                     internal-time-units-per-second)))
+    (format nil "~2,'0d:~2,'0d:~2,'0d" (floor secs (* 60 60))
+                                       (floor (mod secs (* 60 60)) 60)
+                                       (mod secs 60))))
+
+(defun show-status-bar (game state)
+  (let ((bar-top (+ +TOP+ (game:board-height game)))
+        (bar-left (- +LEFT+ 1)))
+    (console:set-pos bar-left bar-top)
+    (console:format "~{~a~}-" (loop REPEAT (* 2 (game:board-width game)) COLLECT "-"))
+    (console:newline)
+
+    (console:move :right (1- bar-left))
+    (console:format " flag: ~d/~d" (game:flag-count game) (state-bomb-count state))
+    (console:format "~18T~a" (elapsed-time state))
+    (console:newline)
+
+    (console:move :right (1- bar-left))
+    (console:format "~{~a~}-" (loop REPEAT (* 2 (game:board-width game)) COLLECT "-"))
+    (console:newline)
+
+    (console:move :right (1- bar-left))
+    (console:format " up:'e' down:'d' left:'s' right:'f'")
+    (console:newline)
+
+    (console:move :right (1- bar-left))
+    (console:format " open:'j' flag:'k' exit:'c'")))
+
+(defun show-game (game state)
+  (show-board game)
+  (show-status-bar game state)
+  (console:set-pos (+ +LEFT+ (* (state-pos-x state) 2))
+                   (+ +TOP+ (state-pos-y state))))
+
+(defun init (width height bomb-count)
+  (console:clear)
+  (let ((game (game:init-game width height))
+        (state (make-state :bomb-count bomb-count)))
+    (show-game game state)
+    (console:set-pos +LEFT+ +TOP+)
+    (values game state)))
+
+(defmacro command-loop ((cmd game state) &body body)
+  (let ((recur (gensym)))
+    `(block nil
+       (labels ((,recur ()
+                  (handler-case 
+                   (let ((,cmd (case (sb-ext:with-timeout 1 (read-char))
+                                 (#\c (return-from ,recur))
+                                 (#\s :left)
+                                 (#\d :down)
+                                 (#\f :right)
+                                 (#\e :up)
+                                 (#\j :open)
+                                 (#\k :flag))))
+
+                     ,@body
+                     (,recur))
+                   (sb-ext:timeout ()
+                     (show-game ,game ,state)
+                     (,recur)))))
+       (,recur)))))
+
+(defun go-up (game state)
+  (declare (ignore game))
+  (when (plusp #1=(state-pos-y state))
+    (console:move :up)
+    (decf #1#)))
+
+(defun go-down (game state)
+  (when (< #1=(state-pos-y state) (1- (game:board-height game)))
+    (console:move :down)
+    (incf #1#)))
+
+(defun go-left (game state)
+  (declare (ignore game))
+  (when (plusp #1=(state-pos-x state))
+    (console:move :left 2)
+    (decf #1#)))
+
+(defun go-right (game state)
+  (when (< #1=(state-pos-x state) (1- (game:board-width game)))
+    (console:move :right 2)
+    (incf #1#)))
+
+(defun game-start (game state)
+  (with-slots (bomb-count pos-x pos-y) state
+    (game:locate-bombs game bomb-count pos-x pos-y)
+    (show-game game state)
+
+    (flet ((check-finish ()
+             (multiple-value-bind (finish complete) (game:finish? game)
+               (when finish
+                 (return-from game-start complete)))))
+      (command-loop (cmd game state)
+        (case cmd
+          (:up    (go-up game state))
+          (:down  (go-down game state))
+          (:left  (go-left game state))
+          (:right (go-right game state))
+          (:flag 
+           (game:flip-flag game pos-x pos-y)
+           (show-game game state)
+           (check-finish))
+          (:open 
+           (game:open-cell game pos-x pos-y)
+           (show-game game state)
+           (check-finish)))))))
+
+(defun show-result (complete? game state)
+  (unless complete?
+    (game:each (cell state) game
+      (when (eq cell :bomb)
+        (setf state :open))))
+  (show-game game state)
+
+  (console:set-pos 1 (+ +TOP+ (game:board-height game) 6))
+  (if complete?
+      (console:format "~a" (console:style "COMPLETE!" :color :green :bold t))
+    (console:format "~a" (console:style "BOMB!" :color :red :bold t)))
+  (console:newline))
+
+(defmain main (width height bomb-count)
+  "Usage: mine WIDTH HEIGHT BOMB_COUNT"
+  (game (parse-integer width) (parse-integer height) (parse-integer bomb-count)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;
+;;; exported functions
 (defun game (width height bomb-count)
-  (declare (ignore width height bomb-count))
-  #+C
   (console:with-raw-mode
-   )
+   (multiple-value-bind (game state) 
+                        (init width height bomb-count)
+     (show-result
+      (command-loop (cmd game state)
+        (case cmd
+          (:up    (go-up game state))
+          (:down  (go-down game state))
+          (:left  (go-left game state))
+          (:right (go-right game state))
+          (:open 
+           (return (game-start game state)))))
+      game state)))
   (values))
 
+(defun make-mine-command (&optional (name "mine"))
+  (sb-ext:save-lisp-and-die 
+   name
+   :toplevel #'main
+   :executable t))

package.lisp

@@ -1,5 +1,6 @@
 (defpackage mine
   (:use :cl)
-  (:export game))
+  (:export game
+           make-mine-command))
 (in-package :mine)