source: trunk/source/examples/gtk-minesweeper.lisp @ 11439

Last change on this file since 11439 was 6, checked in by gb, 16 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 26.7 KB
Line 
1;;;-*-Mode: LISP; Package: (MINESWEEPER :USE (CL CCL)) -*-
2;;;
3;;;   Copyright (C) 2001 Clozure Associates
4;;;
5;;; This is a GTK+-based MineSweeper game, derived from a C program
6;;; developed by Eric Harlow and published in "Developing Linux Programs
7;;; with GTK+ and GDK", (c) 1999 New Riders Publishing.
8;;;
9;;; Anyone who wants to use this code for any purpose is free to do so.
10;;; In doing so, the user acknowledges that this code is provided "as is",
11;;; without warranty of any kind, and that no other party is legally or
12;;; otherwise responsible for any consequences of its use.
13
14(defpackage "MINESWEEPER"
15  (:use "CL" "CCL")
16  (:export "MINESWEEPER"))
17
18(in-package "MINESWEEPER")
19
20;;;
21;;; Make GTK+ interface info available.
22(eval-when (:compile-toplevel :execute)
23  (use-interface-dir :GTK))
24
25(eval-when (:compile-toplevel :load-toplevel :execute)
26  (require "OPENMCL-GTK-SUPPORT"))
27
28
29(defconstant max-rows 35)
30(defconstant max-cols 35)
31
32(defconstant button-width 24)
33(defconstant button-height 26)
34
35
36(defvar *nrows* 10)
37(defvar *ncols* 10)
38(defvar *ntotalbombs* 0)
39
40(defvar *bgameover* nil)
41(defvar *bresetgame* nil)
42(defvar *nbombsleft* nil)
43
44(defvar *table* nil)
45(defvar *start-button* nil)
46(defvar *bombs-label* nil)
47(defvar *time-label* nil)
48(defvar *vbox* nil)
49
50(defstruct cell
51  (buttonstate :button-unknown
52               :type (member (:button-down :button-unknown :button-flagged)))
53  button
54  (bombsnearby 0)
55  (has-bomb nil)
56  row
57  col)
58
59;;; The original C Minesweeper example uses GtkToggleButtons to
60;;; represent the cells on the grid.  They seem to work reasonably
61;;; well except for one minor (but annoying) feature: "enter" and
62;;; "leave" events cause the cells under the mouse to be highlighted,
63;;; making it difficult to distinguish "unpressed buttons" from "the
64;;; button under the mouse".
65;;;
66;;; This defines a GtkQuietToggleButton class that's exactly like
67;;; GtkToggleButton except for the fact that it does nothing on
68;;; "enter" and "leave" events.  It's not necessarily the most
69;;; interesting example of subclassing a Gtk widget, but it -is- an
70;;; example of doing so.
71;;;
72;;; GtkQuietToggleButtons seem to be better, but there is still some
73;;; room for improvement.
74
75(defcallback enter-or-leave-quietly (:address widget :void)
76  (let* ((id (with-cstrs ((cell-id "cell-id"))
77               (#_gtk_object_get_data widget cell-id)))
78         (cell (cell-id->cell id))
79         (desired-state 
80          (if (member (cell-buttonstate cell)
81                      '(:button-unknown :button-flagged))
82            #$GTK_STATE_NORMAL
83            #$GTK_STATE_ACTIVE))
84         (current-state (pref widget :<G>tk<W>idget.state)))
85    (unless (eql current-state desired-state)
86      (#_gtk_widget_set_state widget desired-state))))
87
88(defcallback gtk_quiet_toggle_button_class_init (:address classptr :void)
89  (setf (pref classptr :<G>tk<B>utton<C>lass.enter) enter-or-leave-quietly
90        (pref classptr :<G>tk<B>utton<C>lass.leave) enter-or-leave-quietly))
91
92
93(defcallback gtk_quiet_toggle_button_init (:address widget :void)
94  (declare (ignore widget)))
95
96
97;;; CCL::DEFLOADVAR behaves like DEFPARAMETER, but arranges to
98;;; initialize the variable whenever a saved image start up
99;;; as well as when the DEFLOADVAR is executed.
100(ccl::defloadvar *gtk-quiet-toggle-button-type-info*
101    (let* ((p (#_malloc (ccl::%foreign-type-or-record-size :<G>tk<T>ype<I>nfo :bytes))))
102      (setf
103       (pref p :<G>tk<T>ype<I>nfo.type_name)
104       (with-cstrs ((name "GtkQuietToggleButton")) (#_g_strdup name))
105       (pref p :<G>tk<T>ype<I>nfo.object_size)
106       (ccl::%foreign-type-or-record-size :<G>tk<T>oggle<B>utton :bytes)
107       (pref p :<G>tk<T>ype<I>nfo.class_size)
108       (ccl::%foreign-type-or-record-size :<G>tk<T>oggle<B>utton<C>lass :bytes)
109       (pref p :<G>tk<T>ype<I>nfo.class_init_func) gtk_quiet_toggle_button_class_init
110       (pref p :<G>tk<T>ype<I>nfo.object_init_func) gtk_quiet_toggle_button_init
111       (pref p :<G>tk<T>ype<I>nfo.reserved_1) (%null-ptr)
112       (pref p :<G>tk<T>ype<I>nfo.reserved_2) (%null-ptr)
113       (pref p :<G>tk<T>ype<I>nfo.base_class_init_func) (%null-ptr))
114      p))
115
116(ccl::defloadvar *gtk-quiet-toggle-button-type* nil)
117
118(defun gtk-quiet-toggle-button-get-type ()
119  (or *gtk-quiet-toggle-button-type*
120      (setq *gtk-quiet-toggle-button-type*
121            (#_gtk_type_unique (#_gtk_toggle_button_get_type)
122                               *gtk-quiet-toggle-button-type-info*))))
123
124(defcallback gtk_quiet_toggle_button_get_type (:unsigned-fullword)
125  (gtk-quiet-toggle-button-get-type))
126
127(defun gtk-quiet-toggle-button-new ()
128  (#_gtk_type_new (gtk-quiet-toggle-button-get-type)))
129
130(defcallback gtk_quiet_toggle_button_new (:address)
131  (gtk-quiet-toggle-button-new))
132
133(defparameter *minesweeper-use-quiet-toggle-buttons* t)
134
135;;; Display message dialogs (as for the About... box).
136
137;;; A dialog widget has "grabbed" the focus.  Call back here when
138;;; the dialog is to be closed; yield the focus.
139(defcallback close-show-message
140    (:address container :address data :void)
141  (declare (ignore container))
142  (let* ((dialog-widget data))
143    (#_gtk_grab_remove dialog-widget)
144    (#_gtk_widget_destroy dialog-widget)))
145
146(defcallback clear-show-message
147    (:address widget  :address data :void)
148  (declare (ignore data))
149  (#_gtk_grab_remove widget))
150
151(defun show-message (title message)
152  (let* ((dialog-window (#_gtk_dialog_new)))
153    (with-cstrs ((destroy-name "destroy"))
154      (#_gtk_signal_connect dialog-window destroy-name clear-show-message
155                            (%null-ptr)))
156    (with-cstrs ((title title))
157      (#_gtk_window_set_title dialog-window title))
158    (#_gtk_container_set_border_width dialog-window 0)
159
160    (let* ((button (with-cstrs ((ok "OK"))
161                     (#_gtk_button_new_with_label ok))))
162      (with-cstrs ((clicked "clicked"))
163        (#_gtk_signal_connect button clicked close-show-message dialog-window))
164      (setf (pref button :<G>tk<O>bject.flags)
165            (logior (pref button :<G>tk<O>bject.flags) #$GTK_CAN_DEFAULT))
166      (#_gtk_box_pack_start (pref dialog-window :<G>tk<D>ialog.action_area)
167                            button #$TRUE #$TRUE 0)
168      (#_gtk_widget_grab_default button)
169      (#_gtk_widget_show button))
170
171    (let* ((label (with-cstrs ((message message))
172                    (#_gtk_label_new message))))
173      (#_gtk_misc_set_padding label 10 10)
174      (#_gtk_box_pack_start (pref dialog-window :<G>tk<D>ialog.vbox)
175                            label #$TRUE #$TRUE 0)
176      (#_gtk_widget_show label))
177
178    (#_gtk_widget_show dialog-window)
179    (#_gtk_grab_add dialog-window)))
180
181
182(defun show-about ()
183  (show-message "About ..."
184                "Minesweeper OpenMCL GTK+ example
185Copyright 2001 Clozure Associates
186Derived from Minesweeper v0.6 by Eric Harlow"))
187
188(defvar *win-main* ())
189(defvar *accel-group* ())
190(defvar *tooltips* ())
191
192(defun reset-minesweeper-globals ()
193  (setq *win-main* nil
194        *accel-group* nil
195        *tooltips* nil
196        *vbox* nil
197        *time-label* nil
198        *bombs-label* nil
199        *start-button* nil
200        *table* nil
201        *bgameover* nil
202        *bresetgame* nil))
203       
204(defun create-widget-from-xpm (window xpm-string-list)
205  (rlet ((mask (* :<G>dk<B>itmap)))
206   (with-string-vector (xpm-data xpm-string-list)
207     (let* ((pixmap-data (#_gdk_pixmap_create_from_xpm_d
208                          (pref window :<G>tk<W>idget.window)
209                          mask
210                          (%null-ptr)
211                          xpm-data))
212            (pixmap-widget (#_gtk_pixmap_new pixmap-data (%get-ptr mask))))
213       (#_gtk_widget_show pixmap-widget)
214       pixmap-widget))))
215
216(defun create-menu-item (menu item-name accel tip func data)
217  ;; A null or zero-length item-name indicates a separator.
218  (let* ((menuitem nil))
219    (if (and item-name (length item-name))
220      (with-cstrs ((item-name item-name)
221                   (activate "activate"))
222        (setq menuitem (#_gtk_menu_item_new_with_label item-name))
223        (#_gtk_signal_connect menuitem activate func (or data (%null-ptr))))
224      (setq menuitem (#_gtk_menu_item_new)))
225    (#_gtk_menu_append menu menuitem)
226    (#_gtk_widget_show menuitem)
227
228    (unless *accel-group*
229      (setq *accel-group*
230            (#_gtk_accel_group_new))
231      (#_gtk_accel_group_attach *accel-group*
232                                *win-main*))
233
234    (if (and accel (char= (schar accel 0) #\^))
235      (with-cstrs ((activate "activate"))
236        (#_gtk_widget_add_accelerator
237         menuitem activate *accel-group* (char-code (schar accel 1))
238         #$GDK_CONTROL_MASK #$GTK_ACCEL_VISIBLE)))
239
240    (if (and tip (length tip))
241      (with-cstrs ((tip tip))
242        (#_gtk_tooltips_set_tip
243         (or *tooltips*
244             (setq *tooltips* (#_gtk_tooltips_new)))
245         menuitem
246         tip
247         (%null-ptr))))
248    menuitem))
249   
250(defun create-radio-menu-item (menu item-name group-ptr func data)
251  (with-cstrs ((item-name item-name)
252               (toggled "toggled"))
253    (let* ((menuitem (#_gtk_radio_menu_item_new_with_label
254                      (%get-ptr group-ptr)
255                      item-name)))
256      (setf (%get-ptr group-ptr)
257            (#_gtk_radio_menu_item_group menuitem))
258      (#_gtk_menu_append menu menuitem)
259      (#_gtk_widget_show menuitem)
260      (#_gtk_signal_connect menuitem toggled func (or data (%null-ptr)))
261      menuitem)))
262
263(defun create-bar-sub-menu (menu name)
264  (with-cstrs ((name name))
265    (let* ((menuitem (#_gtk_menu_item_new_with_label name)))
266      (#_gtk_menu_bar_append menu menuitem)
267      (#_gtk_widget_show menuitem)
268      (let* ((submenu (#_gtk_menu_new)))
269        (#_gtk_menu_item_set_submenu menuitem submenu)
270        submenu))))
271
272;;; Represent xpm string vectors as lists of strings.  WITH-STRING-VECTOR
273;;; will produce a foreign vector of C strings out of such a list.
274(defvar *xpm-one*
275  '(
276    "12 12 2 1"
277    "  c None"
278    "X c #3333CC"
279    "            "
280    "     XX     "
281    "    XXX     "
282    "   X XX     "
283    "     XX     "
284    "     XX     "
285    "     XX     "
286    "     XX     "
287    "     XX     "
288    "   XXXXXX   "
289    "            "
290    "            "
291    ))
292
293(defvar *xpm-two*
294  '(
295    "12 12 2 1"
296    "  c None"
297    "X c #009900"
298    "            "
299    "   XXXXXX   "
300    "  X      X  "
301    "        XX  "
302    "       XX   "
303    "      XX    "
304    "     XX     "
305    "    XX      "
306    "   XX       "
307    "  XXXXXXXX  "
308    "            "
309    "            "
310    ))
311
312
313(defvar *xpm-three*
314  '(
315    "12 12 2 1"
316    "  c None"
317    "X c #AA0000"
318    "            "
319    "   XXXXX    "
320    "        XX  "
321    "        XX  "
322    "   XXXXXX   "
323    "        XX  "
324    "        XX  "
325    "        XX  "
326    "        XX  "
327    "  XXXXXX    "
328    "            "
329    "            "
330    ))
331
332
333(defvar *xpm-four*
334  '(
335    "12 12 2 1"
336    "  c None"
337    "X c #000066"
338    "            "
339    "  XX    XX  "
340    "  XX    XX  "
341    "  XX    XX  "
342    "  XX    XX  "
343    "  XXXXXXXX  "
344    "        XX  "
345    "        XX  "
346    "        XX  "
347    "        XX  "
348    "            "
349    "            "
350    ))
351
352
353
354(defvar *xpm-five*
355  '(
356    "12 12 2 1"
357    "  c None"
358    "X c #992299"
359    "            "
360    "  XXXXXXXX  "
361    "  XX        "
362    "  XX        "
363    "  XXXXXXX   "
364    "        XX  "
365    "        XX  "
366    "        XX  "
367    "  XX    XX  "
368    "  XXXXXXX   "
369    "            "
370    "            "
371    ))
372
373
374(defvar *xpm-six*
375  '(
376    "12 12 2 1"
377    "  c None"
378    "X c #550055"
379    "            "
380    "   XXXXXX   "
381    "  XX        "
382    "  XX        "
383    "  XXXXXXX   "
384    "  XX    XX  "
385    "  XX    XX  "
386    "  XX    XX  "
387    "  XX    XX  "
388    "   XXXXXX   "
389    "            "
390    "            "
391    ))
392
393
394
395(defvar *xpm-seven*
396  '(
397    "12 12 2 1"
398    "  c None"
399    "X c #550000"
400    "            "
401    "  XXXXXXXX  "
402    "        XX  "
403    "       XX   "
404    "       XX   "
405    "      XX    "
406    "      XX    "
407    "     WX     "
408    "     XX     "
409    "     XX     "
410    "            "
411    "            "
412    ))
413
414
415
416(defvar *xpm-eight*
417  '(
418    "12 12 2 1"
419    "  c None"
420    "X c #441144"
421    "            "
422    "   XXXXXX   "
423    "  XX    XX  "
424    "  XX    XX  "
425    "   XXXXXX   "
426    "  XX    XX  "
427    "  XX    XX  "
428    "  XX    XX  "
429    "  XX    XX  "
430    "   XXXXXX   "
431    "            "
432    "            "
433    ))
434
435(defvar *xpm-flag*
436  '(
437    "12 12 4 1"
438    "  c None"
439    "X c #000000"
440    "R c #FF0000"
441    "r c #AA0000"
442    "            "
443    "  RRRRRRR   "
444    "  RRRRRrr   "
445    "  RRRrrrr   "
446    "  Rrrrrrr   "
447    "        X   "
448    "        X   "
449    "        X   "
450    "        X   "
451    "        X   "
452    "       XXX  "
453    "            "
454    ))
455
456
457;;;
458;;; --- A bomb.  Ooops, you're not as smart as you thought.
459;;;
460(defvar *xpm-bomb*
461  '(
462    "12 12 4 1"
463    "  c None"
464    "X c #000000"
465    "R c #FF0000"
466    "r c #AA0000"
467    "            "
468    "     X      "
469    "  X  X  X   "
470    "   XXXXX    "
471    "   XXXXX    "
472    " XXXXXXXXX  "
473    "   XXXXX    "
474    "   XXXXX    "
475    "  X  X  X   "
476    "     X      "
477    "            "
478    "            "
479    ))
480
481
482;;;
483;;; --- Wrong move!
484;;;
485(defvar *xpm-bigx*
486  '(
487    "12 12 4 1"
488    "  c None"
489    "X c #000000"
490    "R c #FF0000"
491    "r c #AA0000"
492    "RRR      RRR"
493    " RRR    RRR "
494    "  RRR  RRR  "
495    "   RRRRRR   "
496    "    RRRR    "
497    "    RRRR    "
498    "    RRRR    "
499    "   RRRRRR   "
500    "  RRR  RRR  "
501    " RRR    RRR "
502    "RRR      RRR"
503    "            "
504    ))
505
506
507;;;
508;;; --- Bitmap of a smile
509;;;
510(defvar *xpm-smile*
511  '(
512    "16 16 4 1"
513    "  c None"
514    ". c #000000"
515    "X c #FFFF00"
516    "r c #AA0000"
517    "     ......     "
518    "   ..XXXXXX..   "
519    " ..XXXXXXXXXX.  "
520    " .XXXXXXXXXXXX. "
521    " .XX..XXXX..XX. "
522    ".XXX..XXXX..XXX."
523    ".XXXXXXXXXXXXXX."
524    ".XXXXXXXXXXXXXX."
525    ".XXXXXXXXXXXXXX."
526    ".XXXXXXXXXXXXXX."
527    " .XX.XXXXXX.XX. "
528    " .XXX......XXX. "
529    "  .XXXXXXXXXX.  "
530    "   ..XXXXXX..   "
531    "     ......     "
532    "                "
533    ))
534
535
536;;;
537;;; --- frown.  You lost.
538;;;
539(defvar *xpm-frown*
540  '(
541    "16 16 4 1"
542    "  c None"
543    ". c #000000"
544    "X c #FFFF00"
545    "r c #AA0000"
546    "     ......     "
547    "   ..XXXXXX..   "
548    " ..XXXXXXXXXX.  "
549    " .XXXXXXXXXXXX. "
550    " .XX.X.XX.X.XX. "
551    ".XXXX.XXXX.XXXX."
552    ".XXX.X.XX.X.XXX."
553    ".XXXXXXXXXXXXXX."
554    ".XXXXXXXXXXXXXX."
555    ".XXXXXXXXXXXXXX."
556    " .XXX......XXX. "
557    " .XX.XXXXXX.XX. "
558    "  .XXXXXXXXXX.  "
559    "   ..XXXXXX..   "
560    "     ......     "
561    "                "
562    ))
563
564
565;;;
566;;; --- We have a winner
567;;;
568(defvar *xpm-winner*
569  '(
570    "16 16 4 1"
571    "  c None"
572    ". c #000000"
573    "X c #FFFF00"
574    "r c #AA0000"
575    "     ......     "
576    "   ..XXXXXX..   "
577    " ..XXXXXXXXXX.  "
578    " .XXXXXXXXXXXX. "
579    " .XX...XX...XX. "
580    ".XX..........XX."
581    ".X.X...XX...X.X."
582    "..XXXXXXXXXXXX.."
583    ".XXXXXXXXXXXXXX."
584    ".XXXXXXXXXXXXXX."
585    " .XX.XXXXXX.XX. "
586    " .XXX......XXX. "
587    "  .XXXXXXXXXX.  "
588    "   ..XXXXXX..   "
589    "     ......     "
590    "                "
591    ))
592
593(defvar *digits*
594  (vector nil *xpm-one* *xpm-two* *xpm-three* *xpm-four* *xpm-five*
595          *xpm-six* *xpm-seven* *xpm-eight*))
596
597(defun set-grid (ncols nrows nbombs)
598  (when *table*
599    (#_gtk_widget_destroy *table*))
600  (setq *table* (#_gtk_table_new ncols nrows #$FALSE))
601  (#_gtk_box_pack_start *vbox* *table* #$FALSE #$FALSE 0)
602  (#_gtk_widget_realize *table*)
603  (reset-game ncols nrows nbombs t)
604  (#_gtk_widget_show *table*))
605
606
607;;; Menu callbacks.
608
609;;; This is called both when the start button is pressed and when
610;;; the "New" menu item is selected.
611(defcallback start-button-clicked (:address widget :address data :void)
612  (declare (ignore widget data))
613  (set-start-button-icon *xpm-smile*)
614  (reset-game *ncols* *nrows* *ntotalbombs* nil))
615
616(defcallback action-beginner 
617    (:address widget :address data :void)
618  (declare (ignore data))
619  (unless (zerop (pref widget :<G>tk<C>heck<M>enu<I>tem.active))
620    (set-grid 10 10 10)))
621
622(defcallback action-intermediate 
623    (:address widget :address data :void)
624  (declare (ignore data))
625  (unless (zerop (pref widget :<G>tk<C>heck<M>enu<I>tem.active))
626    (set-grid 20 15 40)))
627
628(defcallback action-advanced
629    (:address widget :address data :void)
630  (declare (ignore data))
631  (unless (zerop (pref widget :<G>tk<C>heck<M>enu<I>tem.active))
632    (set-grid 30 20 100)))
633
634(defcallback action-quit (:address widget :address data :void)
635  (declare (ignore widget))
636  (stop-timer)
637  (#_gtk_widget_destroy data)
638  (reset-minesweeper-globals))
639
640(defcallback action-about (:void)
641  (show-about))
642
643(defun create-menu (window vbox-main)
644  (setq *win-main* window)
645  (setq *accel-group* (#_gtk_accel_group_new))
646  (#_gtk_accel_group_attach *accel-group* *win-main*)
647  (let* ((menubar (#_gtk_menu_bar_new)))
648    (#_gtk_box_pack_start vbox-main menubar #$FALSE #$TRUE 0)
649    (#_gtk_widget_show menubar)
650    (let* ((game-menu (create-bar-sub-menu menubar "Game")))
651      (create-menu-item game-menu
652                        "New" "^N" "New Game" start-button-clicked nil)
653      (create-menu-item game-menu nil nil nil nil nil)
654      (rlet ((group (* t)))
655        (setf (%get-ptr group) (%null-ptr))
656        (with-macptrs ((group-ptr group))
657          (create-radio-menu-item game-menu "Beginner" group-ptr
658                                  action-beginner nil)
659          (create-radio-menu-item game-menu "Intermediate" group-ptr
660                                  action-intermediate nil)
661          (create-radio-menu-item game-menu "Advanced" group-ptr
662                                  action-advanced nil)))
663      (create-menu-item game-menu nil nil nil nil nil)
664      (create-menu-item game-menu "Quit" nil "Quit game"
665                        action-quit  *win-main*))
666    (let* ((help-menu (create-bar-sub-menu menubar "Help")))
667      (create-menu-item help-menu "About Minesweeper" nil "Gory Details"
668                        action-about nil))))
669   
670
671
672
673(defparameter *cells*
674  (let* ((a (make-array (list max-cols max-rows))))
675    (dotimes (row max-rows a)
676      (dotimes (col max-cols)
677        (setf (aref a col row)
678              (make-cell :row row :col col))))))
679
680;;; Callbacks can receive (foreign) pointer arguments.  Since we'd
681;;; rather keep information in lisp structures/arrays, that's not
682;;; directly helpful.
683
684;;; We can identify a cell by its row and column and
685;;; can easily pack the row and column into a fixnum.  This function's
686;;; caller can coerce that fixnum into a pointer (via ccl::%int-to-ptr).
687
688(defun cell->cell-id (cell)
689  (dpb (cell-row cell)
690       (byte 8 8)
691       (cell-col cell)))
692
693;;; The inverse operation: the caller (a callback) will generally have
694;;; a foreign pointer; it can coerce that to a fixnum and obtain the
695;;; corresponding cell by unpacking its indices from that fixnum.
696
697(defun cell-id->cell (cell-id)
698  (let* ((id (if (typep cell-id 'macptr)
699               (%ptr-to-int cell-id)
700               cell-id))
701         (row (ldb (byte 8 8) id))
702         (col (ldb (byte 8 0) id)))
703    (declare (fixnum id row col))
704    (aref *cells* col row)))
705
706;;; Free widget.
707(defcallback FreeChildCallback (:address widget :void)
708  (#_gtk_widget_destroy widget))
709
710;;; Free all of the widgets contained in this one.
711(defun free-children (widget)
712  (#_gtk_container_foreach
713   (#_gtk_type_check_object_cast widget (#_gtk_container_get_type))
714                                 FreeChildCallback (%null-ptr)))
715
716(defun add-image-to-mine (cell xpm-data)
717  (let* ((widget (create-widget-from-xpm *table* xpm-data)))
718    (#_gtk_container_add (cell-button cell) widget)
719    (#_gdk_pixmap_unref widget)
720    nil))
721
722(defun open-nearby-squares (col row)
723  (declare (fixnum col row))
724  (let* ((mincol (max (1- col) 0))
725         (maxcol (min (1+ col) (1- *ncols*)))
726         (minrow (max (1- row) 0))
727         (maxrow (min (1+ row) (1- *nrows*))))
728    (declare (fixnum mincol maxcol minrow maxrow))
729    (do* ((i mincol (1+ i)))
730         ((> i maxcol))
731      (declare (fixnum i))
732      (do* ((j minrow (1+ j)))
733           ((> j maxrow))
734        (declare (fixnum j))
735        (display-hidden-info (aref *cells* i j))))))
736   
737(defun display-hidden-info (cell)
738  (case (cell-buttonstate cell)
739    (:button-down
740     (#_gtk_toggle_button_set_active (cell-button cell) #$TRUE))
741    (:button-flagged
742     (#_gtk_toggle_button_set_active (cell-button cell) #$FALSE))
743    (t
744     (setf (cell-buttonstate cell) :button-down)
745     (#_gtk_toggle_button_set_active (cell-button cell) #$TRUE)
746     (setf (pref (cell-button cell) :<G>tk<B>utton.button_down) #$TRUE)
747     (if (cell-has-bomb cell)
748       (add-image-to-mine cell *xpm-bomb*)
749       (let* ((nearby-bombs (cell-bombsnearby cell)))
750         (declare (fixnum nearby-bombs))
751         (if (> nearby-bombs 0)
752           (add-image-to-mine cell (svref *digits* nearby-bombs))
753           (open-nearby-squares (cell-col cell) (cell-row cell))))))))
754
755(defun show-bombs ()
756  (dotimes (i *ncols*)
757    (dotimes (j *nrows*)
758      (let* ((cell (aref *cells* i j))
759             (buttonstate (cell-buttonstate cell))
760             (has-bomb (cell-has-bomb cell)))
761        (if (and (eq buttonstate :button-unknown) has-bomb)
762          (display-hidden-info cell)
763          (when (and (eq buttonstate :button-flagged) (not has-bomb))
764            (free-children (cell-button cell))
765            (add-image-to-mine cell *xpm-bigx*)))))))
766
767             
768 
769(defcallback cell-toggled (:address widget :address data :void)
770  (let* ((cell (cell-id->cell data))
771         (state (cell-buttonstate cell)))
772    (unless (eq state :button-flagged)
773      (if *bgameover*
774        (#_gtk_toggle_button_set_active widget
775                                        (if (eq state
776                                                :button-down)
777                                          #$TRUE
778                                          #$FALSE))
779        (unless *bresetgame*
780          (start-timer)
781          (cond ((cell-has-bomb cell)
782                 (setq *bgameover* t)
783                 (set-start-button-icon *xpm-frown*)
784                 (stop-timer)
785                 (show-bombs))
786                (t
787                 (display-hidden-info cell)
788                 (check-for-win))))))))
789
790
791
792(defcallback button-press (:address widget :address event :address data :void)
793  (unless *bgameover*
794    (when (and (eql (pref event :<G>dk<E>vent<B>utton.type) #$GDK_BUTTON_PRESS)
795               (eql (pref event :<G>dk<E>vent<B>utton.button) 3))
796      (let* ((cell (cell-id->cell data)))
797        (case (cell-buttonstate cell)
798          (:button-unknown
799           (free-children widget)
800           (setf (cell-buttonstate cell) :button-flagged)
801           (add-image-to-mine cell *xpm-flag*)
802           (decf *nbombsleft*))
803          (:button-flagged
804           (free-children widget)
805           (setf (cell-buttonstate cell) :button-unknown)
806           (incf *nbombsleft*)))
807        (display-bomb-count)
808        (check-for-win)))))
809
810
811
812
813(defun set-start-button-icon (xpm-list)
814  (let* ((widget (create-widget-from-xpm *start-button* xpm-list)))
815    (free-children *start-button*)
816    (#_gtk_container_add *start-button* widget)))
817   
818(defun check-for-win ()
819  (let* ((nmines 0))
820    (declare (fixnum nmines))
821    (dotimes (col *ncols*)
822      (declare (fixnum col))
823      (dotimes (row *nrows*)
824        (declare (fixnum row))
825        (when (member (cell-buttonstate (aref *cells* col row))
826                      '(:button-unknown :button-flagged))
827          (incf nmines))))
828    (when (= nmines (the fixnum *ntotalbombs*))
829      (stop-timer)
830      (set-start-button-icon *xpm-winner*)
831      (setq *bgameover* t))))
832
833
834(defun create-button (table cell row column)
835  (let* ((button
836          (if *minesweeper-use-quiet-toggle-buttons*
837            (let* ((b (gtk-quiet-toggle-button-new))
838                   (id (cell->cell-id (aref *cells* column row))))
839              (with-cstrs ((cell-id "cell-id"))
840                (#_gtk_object_set_data b cell-id (%int-to-ptr id)))
841              b)
842            (#_gtk_toggle_button_new)))
843         (cell-id (cell->cell-id cell)))
844    (with-cstrs ((toggled "toggled")
845                 (button-press-event "button_press_event"))
846      (#_gtk_signal_connect button toggled cell-toggled
847                            (%int-to-ptr cell-id))
848      (#_gtk_signal_connect button button-press-event
849                            button-press (%int-to-ptr cell-id)))
850    (#_gtk_table_attach table button
851                        column (1+ column)
852                        (1+ row) (+ row 2)
853                        (logior #$GTK_FILL #$GTK_EXPAND)
854                        (logior #$GTK_FILL #$GTK_EXPAND)
855                        0 0)
856    (#_gtk_widget_set_usize button button-width button-height)
857    (#_gtk_widget_show button)
858    button))
859
860   
861(defun count-nearby-bombs (col row)
862  (declare (fixnum col row))
863  (let* ((mincol (max (1- col) 0))
864         (maxcol (min (1+ col) (1- *ncols*)))
865         (minrow (max (1- row) 0))
866         (maxrow (min (1+ row) (1- *nrows*)))
867         (ncount 0))
868    (declare (fixnum mincol maxcol minrow maxrow ncount))
869    (do* ((i mincol (1+ i)))
870         ((> i maxcol) ncount)
871      (declare (fixnum i))
872      (do* ((j minrow (1+ j)))
873           ((> j maxrow))
874        (declare (fixnum j))
875        (if (cell-has-bomb (aref *cells* i j))
876          (incf ncount))))))
877
878(defun display-bomb-count ()
879  (with-cstrs ((buf (format nil "Bombs: ~d" *nbombsleft*)))
880    (#_gtk_label_set_text *bombs-label* buf)))
881
882(defun update-seconds (seconds)
883  (with-cstrs ((buf (format nil "Time: ~d" seconds)))
884    (#_gtk_label_set_text *time-label* buf)))
885 
886(defun create-minesweeper-buttons (table ngridcols ngridrows bnewbuttons)
887  (setq *nrows* ngridrows
888        *ncols* ngridcols
889        *bgameover* nil
890        *bresetgame* t)
891  (display-bomb-count)
892  (dotimes (ci *ncols*)
893    (declare (fixnum ci))
894    (dotimes (ri *nrows*)
895      (declare (fixnum ri))
896      (let* ((cell (aref *cells* ci ri)))
897        (setf (cell-has-bomb cell) nil
898              (cell-buttonstate cell) :button-unknown)
899        (if bnewbuttons
900          (setf (cell-button cell) (create-button table cell ri ci))
901          (progn
902            (free-children (cell-button cell))
903            (#_gtk_toggle_button_set_active (cell-button cell) #$FALSE))))))
904  (do* ((nbombs *ntotalbombs*)
905        (state (make-random-state t)))
906       ((zerop nbombs))
907    (declare (fixnum nbombs))
908    (let* ((cell (aref *cells* (random *ncols* state) (random *nrows* state))))
909      (unless (cell-has-bomb cell)
910        (setf (cell-has-bomb cell) t)
911        (decf nbombs))))
912  (dotimes (ci *ncols*)
913    (declare (fixnum ci))
914    (dotimes (ri *nrows*)
915      (declare (fixnum ri))
916      (setf (cell-bombsnearby (aref *cells* ci ri))
917            (count-nearby-bombs ci ri))))
918  (setq *bresetgame* nil))
919                   
920(defun reset-game (ncols nrows nbombs bnewbuttons)
921  (setq *ntotalbombs* nbombs
922        *nbombsleft* nbombs)
923  (create-minesweeper-buttons *table* ncols nrows bnewbuttons)
924  (stop-timer)
925  (update-seconds 0)
926  (set-start-button-icon *xpm-smile*))
927
928
929             
930;;; Timer stuff.
931
932(defvar *timer* nil)
933(defvar *nseconds* 0)
934
935(defcallback timer-callback (:address data :void)
936  (declare (ignore data))
937  (incf *nseconds*)
938  (update-seconds *nseconds*))
939
940(defun start-timer ()
941  (unless *timer*
942    (setq *nseconds* 0
943          *timer* (#_gtk_timeout_add 1000 timer-callback *win-main*))))
944
945(defun stop-timer ()
946  (when *timer*
947    (#_gtk_timeout_remove *timer*)
948    (setq *timer* nil)))
949
950
951;;; Finally ...
952
953(defun minesweeper ()
954  (when *win-main*
955    (cerror
956     "Close current minesweeper game and start a new one"
957     "It seems that a minesweeper game is already active.")
958    (do* ()
959         ((null *win-main*))
960      (#_gtk_widget_destroy *win-main*)
961      (sleep 1)))
962  (let* ((window (#_gtk_window_new #$GTK_WINDOW_TOPLEVEL)))
963    (#_gtk_window_set_policy window #$FALSE #$FALSE #$TRUE)
964    (with-cstrs ((window-title "Minesweeper"))
965      (#_gtk_window_set_title window window-title)
966      (setq *vbox* (#_gtk_vbox_new #$FALSE 1))
967      (#_gtk_widget_show *vbox*)
968      (create-menu window *vbox*)
969      (let* ((hbox (#_gtk_hbox_new #$TRUE 1)))
970        (#_gtk_widget_show hbox)
971        (#_gtk_box_pack_start *vbox* hbox #$FALSE #$FALSE 0)
972        (with-cstrs ((len0-string ""))
973          (setq *bombs-label* (#_gtk_label_new len0-string)
974                *time-label* (#_gtk_label_new len0-string)))
975        (#_gtk_box_pack_start hbox *bombs-label* #$FALSE #$FALSE 0)
976        (#_gtk_widget_show *bombs-label*)
977        (setq *start-button* (#_gtk_button_new))
978        (with-cstrs ((clicked "clicked"))
979          (#_gtk_signal_connect *start-button* clicked start-button-clicked
980                                (%null-ptr)))
981        (#_gtk_box_pack_start hbox *start-button* #$FALSE #$FALSE 0)
982        (#_gtk_widget_show *start-button*)
983        (#_gtk_box_pack_start hbox *time-label* #$FALSE #$FALSE 0)
984        (#_gtk_widget_show *time-label*)
985        (#_gtk_widget_show hbox)
986        (#_gtk_container_add window *vbox*)
987        (with-cstrs ((destroy "destroy"))
988          (#_gtk_signal_connect window destroy action-quit window))
989        (#_gtk_widget_show window)
990
991        (set-start-button-icon *xpm-smile*)
992        (set-grid 10 10 10)))))
Note: See TracBrowser for help on using the repository browser.