source: release/1.9/source/examples/gtk-minesweeper.lisp @ 15774

Last change on this file since 15774 was 12845, checked in by gb, 10 years ago

Try to update this a bit (gtk+-1/gtk+-2), but it needs more work.
(It'd be nice to have a working GTK example or two, but some of this
hasn't worked in a long time.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 27.0 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 :GTK2))
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_full dialog-window destroy-name clear-show-message
155                            (%null-ptr) (%null-ptr) (%null-ptr) 0 0))
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_full button clicked close-show-message (%null-ptr) dialog-window (%null-ptr) 0 0))
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_full menuitem activate func (%null-ptr) (or data (%null-ptr)) (%null-ptr) 0 0))
224      (setq menuitem (#_gtk_menu_item_new)))
225    (#_gtk_menu_shell_append menu menuitem)
226    (#_gtk_widget_show menuitem)
227
228    (unless *accel-group*
229      (setq *accel-group*
230            (#_gtk_accel_group_new))
231      (#_gtk_window_add_accel_group *win-main* *accel-group*))
232
233    (if (and accel (char= (schar accel 0) #\^))
234      (with-cstrs ((activate "activate"))
235        (#_gtk_widget_add_accelerator
236         menuitem activate *accel-group* (char-code (schar accel 1))
237         #$GDK_CONTROL_MASK #$GTK_ACCEL_VISIBLE)))
238
239    (if (and tip (length tip))
240      (with-cstrs ((tip tip))
241        (#_gtk_tooltips_set_tip
242         (or *tooltips*
243             (setq *tooltips* (#_gtk_tooltips_new)))
244         menuitem
245         tip
246         (%null-ptr))))
247    menuitem))
248   
249(defun create-radio-menu-item (menu item-name group-ptr func data)
250  (with-cstrs ((item-name item-name)
251               (toggled "toggled"))
252    (let* ((menuitem (#_gtk_radio_menu_item_new_with_label
253                      (%get-ptr group-ptr)
254                      item-name)))
255      (setf (%get-ptr group-ptr)
256            (#_gtk_radio_menu_item_get_group menuitem))
257      (#_gtk_menu_shell_append menu menuitem)
258      (#_gtk_widget_show menuitem)
259      (#_gtk_signal_connect_full menuitem toggled func (%null-ptr) (or data (%null-ptr)) (%null-ptr) 0 0)
260      menuitem)))
261
262(defun create-bar-sub-menu (menu name)
263  (with-cstrs ((name name))
264    (let* ((menuitem (#_gtk_menu_item_new_with_label name)))
265      (#_gtk_menu_shell_append menu menuitem)
266      (#_gtk_widget_show menuitem)
267      (let* ((submenu (#_gtk_menu_new)))
268        (#_gtk_menu_item_set_submenu menuitem submenu)
269        submenu))))
270
271;;; Represent xpm string vectors as lists of strings.  WITH-STRING-VECTOR
272;;; will produce a foreign vector of C strings out of such a list.
273(defvar *xpm-one*
274  '(
275    "12 12 2 1"
276    "  c None"
277    "X c #3333CC"
278    "            "
279    "     XX     "
280    "    XXX     "
281    "   X XX     "
282    "     XX     "
283    "     XX     "
284    "     XX     "
285    "     XX     "
286    "     XX     "
287    "   XXXXXX   "
288    "            "
289    "            "
290    ))
291
292(defvar *xpm-two*
293  '(
294    "12 12 2 1"
295    "  c None"
296    "X c #009900"
297    "            "
298    "   XXXXXX   "
299    "  X      X  "
300    "        XX  "
301    "       XX   "
302    "      XX    "
303    "     XX     "
304    "    XX      "
305    "   XX       "
306    "  XXXXXXXX  "
307    "            "
308    "            "
309    ))
310
311
312(defvar *xpm-three*
313  '(
314    "12 12 2 1"
315    "  c None"
316    "X c #AA0000"
317    "            "
318    "   XXXXX    "
319    "        XX  "
320    "        XX  "
321    "   XXXXXX   "
322    "        XX  "
323    "        XX  "
324    "        XX  "
325    "        XX  "
326    "  XXXXXX    "
327    "            "
328    "            "
329    ))
330
331
332(defvar *xpm-four*
333  '(
334    "12 12 2 1"
335    "  c None"
336    "X c #000066"
337    "            "
338    "  XX    XX  "
339    "  XX    XX  "
340    "  XX    XX  "
341    "  XX    XX  "
342    "  XXXXXXXX  "
343    "        XX  "
344    "        XX  "
345    "        XX  "
346    "        XX  "
347    "            "
348    "            "
349    ))
350
351
352
353(defvar *xpm-five*
354  '(
355    "12 12 2 1"
356    "  c None"
357    "X c #992299"
358    "            "
359    "  XXXXXXXX  "
360    "  XX        "
361    "  XX        "
362    "  XXXXXXX   "
363    "        XX  "
364    "        XX  "
365    "        XX  "
366    "  XX    XX  "
367    "  XXXXXXX   "
368    "            "
369    "            "
370    ))
371
372
373(defvar *xpm-six*
374  '(
375    "12 12 2 1"
376    "  c None"
377    "X c #550055"
378    "            "
379    "   XXXXXX   "
380    "  XX        "
381    "  XX        "
382    "  XXXXXXX   "
383    "  XX    XX  "
384    "  XX    XX  "
385    "  XX    XX  "
386    "  XX    XX  "
387    "   XXXXXX   "
388    "            "
389    "            "
390    ))
391
392
393
394(defvar *xpm-seven*
395  '(
396    "12 12 2 1"
397    "  c None"
398    "X c #550000"
399    "            "
400    "  XXXXXXXX  "
401    "        XX  "
402    "       XX   "
403    "       XX   "
404    "      XX    "
405    "      XX    "
406    "     WX     "
407    "     XX     "
408    "     XX     "
409    "            "
410    "            "
411    ))
412
413
414
415(defvar *xpm-eight*
416  '(
417    "12 12 2 1"
418    "  c None"
419    "X c #441144"
420    "            "
421    "   XXXXXX   "
422    "  XX    XX  "
423    "  XX    XX  "
424    "   XXXXXX   "
425    "  XX    XX  "
426    "  XX    XX  "
427    "  XX    XX  "
428    "  XX    XX  "
429    "   XXXXXX   "
430    "            "
431    "            "
432    ))
433
434(defvar *xpm-flag*
435  '(
436    "12 12 4 1"
437    "  c None"
438    "X c #000000"
439    "R c #FF0000"
440    "r c #AA0000"
441    "            "
442    "  RRRRRRR   "
443    "  RRRRRrr   "
444    "  RRRrrrr   "
445    "  Rrrrrrr   "
446    "        X   "
447    "        X   "
448    "        X   "
449    "        X   "
450    "        X   "
451    "       XXX  "
452    "            "
453    ))
454
455
456;;;
457;;; --- A bomb.  Ooops, you're not as smart as you thought.
458;;;
459(defvar *xpm-bomb*
460  '(
461    "12 12 4 1"
462    "  c None"
463    "X c #000000"
464    "R c #FF0000"
465    "r c #AA0000"
466    "            "
467    "     X      "
468    "  X  X  X   "
469    "   XXXXX    "
470    "   XXXXX    "
471    " XXXXXXXXX  "
472    "   XXXXX    "
473    "   XXXXX    "
474    "  X  X  X   "
475    "     X      "
476    "            "
477    "            "
478    ))
479
480
481;;;
482;;; --- Wrong move!
483;;;
484(defvar *xpm-bigx*
485  '(
486    "12 12 4 1"
487    "  c None"
488    "X c #000000"
489    "R c #FF0000"
490    "r c #AA0000"
491    "RRR      RRR"
492    " RRR    RRR "
493    "  RRR  RRR  "
494    "   RRRRRR   "
495    "    RRRR    "
496    "    RRRR    "
497    "    RRRR    "
498    "   RRRRRR   "
499    "  RRR  RRR  "
500    " RRR    RRR "
501    "RRR      RRR"
502    "            "
503    ))
504
505
506;;;
507;;; --- Bitmap of a smile
508;;;
509(defvar *xpm-smile*
510  '(
511    "16 16 4 1"
512    "  c None"
513    ". c #000000"
514    "X c #FFFF00"
515    "r c #AA0000"
516    "     ......     "
517    "   ..XXXXXX..   "
518    " ..XXXXXXXXXX.  "
519    " .XXXXXXXXXXXX. "
520    " .XX..XXXX..XX. "
521    ".XXX..XXXX..XXX."
522    ".XXXXXXXXXXXXXX."
523    ".XXXXXXXXXXXXXX."
524    ".XXXXXXXXXXXXXX."
525    ".XXXXXXXXXXXXXX."
526    " .XX.XXXXXX.XX. "
527    " .XXX......XXX. "
528    "  .XXXXXXXXXX.  "
529    "   ..XXXXXX..   "
530    "     ......     "
531    "                "
532    ))
533
534
535;;;
536;;; --- frown.  You lost.
537;;;
538(defvar *xpm-frown*
539  '(
540    "16 16 4 1"
541    "  c None"
542    ". c #000000"
543    "X c #FFFF00"
544    "r c #AA0000"
545    "     ......     "
546    "   ..XXXXXX..   "
547    " ..XXXXXXXXXX.  "
548    " .XXXXXXXXXXXX. "
549    " .XX.X.XX.X.XX. "
550    ".XXXX.XXXX.XXXX."
551    ".XXX.X.XX.X.XXX."
552    ".XXXXXXXXXXXXXX."
553    ".XXXXXXXXXXXXXX."
554    ".XXXXXXXXXXXXXX."
555    " .XXX......XXX. "
556    " .XX.XXXXXX.XX. "
557    "  .XXXXXXXXXX.  "
558    "   ..XXXXXX..   "
559    "     ......     "
560    "                "
561    ))
562
563
564;;;
565;;; --- We have a winner
566;;;
567(defvar *xpm-winner*
568  '(
569    "16 16 4 1"
570    "  c None"
571    ". c #000000"
572    "X c #FFFF00"
573    "r c #AA0000"
574    "     ......     "
575    "   ..XXXXXX..   "
576    " ..XXXXXXXXXX.  "
577    " .XXXXXXXXXXXX. "
578    " .XX...XX...XX. "
579    ".XX..........XX."
580    ".X.X...XX...X.X."
581    "..XXXXXXXXXXXX.."
582    ".XXXXXXXXXXXXXX."
583    ".XXXXXXXXXXXXXX."
584    " .XX.XXXXXX.XX. "
585    " .XXX......XXX. "
586    "  .XXXXXXXXXX.  "
587    "   ..XXXXXX..   "
588    "     ......     "
589    "                "
590    ))
591
592(defvar *digits*
593  (vector nil *xpm-one* *xpm-two* *xpm-three* *xpm-four* *xpm-five*
594          *xpm-six* *xpm-seven* *xpm-eight*))
595
596(defun set-grid (ncols nrows nbombs)
597  (when *table*
598    (#_gtk_widget_destroy *table*))
599  (setq *table* (#_gtk_table_new ncols nrows #$FALSE))
600  (#_gtk_box_pack_start *vbox* *table* #$FALSE #$FALSE 0)
601  (#_gtk_widget_realize *table*)
602  (reset-game ncols nrows nbombs t)
603  (#_gtk_widget_show *table*))
604
605
606;;; Menu callbacks.
607
608;;; This is called both when the start button is pressed and when
609;;; the "New" menu item is selected.
610(defcallback start-button-clicked (:address widget :address data :void)
611  (declare (ignore widget data))
612  (set-start-button-icon *xpm-smile*)
613  (reset-game *ncols* *nrows* *ntotalbombs* nil))
614
615(defcallback action-beginner 
616    (:address widget :address data :void)
617  (declare (ignore data))
618  (unless (zerop (pref widget :<G>tk<C>heck<M>enu<I>tem.active))
619    (set-grid 10 10 10)))
620
621(defcallback action-intermediate 
622    (:address widget :address data :void)
623  (declare (ignore data))
624  (unless (zerop (pref widget :<G>tk<C>heck<M>enu<I>tem.active))
625    (set-grid 20 15 40)))
626
627(defcallback action-advanced
628    (:address widget :address data :void)
629  (declare (ignore data))
630  (unless (zerop (pref widget :<G>tk<C>heck<M>enu<I>tem.active))
631    (set-grid 30 20 100)))
632
633(defcallback action-quit (:address widget :address data :void)
634  (declare (ignore widget))
635  (stop-timer)
636  (#_gtk_widget_destroy data)
637  (reset-minesweeper-globals))
638
639(defcallback action-about (:void)
640  (show-about))
641
642(defun create-menu (window vbox-main)
643  (setq *win-main* window)
644  (setq *accel-group* (#_gtk_accel_group_new))
645  (#_gtk_window_add_accel_group *win-main* *accel-group*)
646  (let* ((menubar (#_gtk_menu_bar_new)))
647    (#_gtk_box_pack_start vbox-main menubar #$FALSE #$TRUE 0)
648    (#_gtk_widget_show menubar)
649    (let* ((game-menu (create-bar-sub-menu menubar "Game")))
650      (create-menu-item game-menu
651                        "New" "^N" "New Game" start-button-clicked nil)
652      (create-menu-item game-menu nil nil nil nil nil)
653      (rlet ((group (* t)))
654        (setf (%get-ptr group) (%null-ptr))
655        (with-macptrs ((group-ptr group))
656          (create-radio-menu-item game-menu "Beginner" group-ptr
657                                  action-beginner nil)
658          (create-radio-menu-item game-menu "Intermediate" group-ptr
659                                  action-intermediate nil)
660          (create-radio-menu-item game-menu "Advanced" group-ptr
661                                  action-advanced nil)))
662      (create-menu-item game-menu nil nil nil nil nil)
663      (create-menu-item game-menu "Quit" nil "Quit game"
664                        action-quit  *win-main*))
665    (let* ((help-menu (create-bar-sub-menu menubar "Help")))
666      (create-menu-item help-menu "About Minesweeper" nil "Gory Details"
667                        action-about nil))))
668   
669
670
671
672(defparameter *cells*
673  (let* ((a (make-array (list max-cols max-rows))))
674    (dotimes (row max-rows a)
675      (dotimes (col max-cols)
676        (setf (aref a col row)
677              (make-cell :row row :col col))))))
678
679;;; Callbacks can receive (foreign) pointer arguments.  Since we'd
680;;; rather keep information in lisp structures/arrays, that's not
681;;; directly helpful.
682
683;;; We can identify a cell by its row and column and
684;;; can easily pack the row and column into a fixnum.  This function's
685;;; caller can coerce that fixnum into a pointer (via ccl::%int-to-ptr).
686
687(defun cell->cell-id (cell)
688  (dpb (cell-row cell)
689       (byte 8 8)
690       (cell-col cell)))
691
692;;; The inverse operation: the caller (a callback) will generally have
693;;; a foreign pointer; it can coerce that to a fixnum and obtain the
694;;; corresponding cell by unpacking its indices from that fixnum.
695
696(defun cell-id->cell (cell-id)
697  (let* ((id (if (typep cell-id 'macptr)
698               (%ptr-to-int cell-id)
699               cell-id))
700         (row (ldb (byte 8 8) id))
701         (col (ldb (byte 8 0) id)))
702    (declare (fixnum id row col))
703    (aref *cells* col row)))
704
705;;; Free widget.
706(defcallback FreeChildCallback (:address widget :void)
707  (#_gtk_widget_destroy widget))
708
709;;; Free all of the widgets contained in this one.
710(defun free-children (widget)
711  (#_gtk_container_foreach
712   (#_g_type_check_instance_cast widget (#_gtk_container_get_type))
713   FreeChildCallback (%null-ptr)))
714
715(defun add-image-to-mine (cell xpm-data)
716  (let* ((widget (create-widget-from-xpm *table* xpm-data)))
717    (#_gtk_container_add (cell-button cell) widget)
718    (#_gdk_drawable_unref widget)
719    nil))
720
721(defun open-nearby-squares (col row)
722  (declare (fixnum col row))
723  (let* ((mincol (max (1- col) 0))
724         (maxcol (min (1+ col) (1- *ncols*)))
725         (minrow (max (1- row) 0))
726         (maxrow (min (1+ row) (1- *nrows*))))
727    (declare (fixnum mincol maxcol minrow maxrow))
728    (do* ((i mincol (1+ i)))
729         ((> i maxcol))
730      (declare (fixnum i))
731      (do* ((j minrow (1+ j)))
732           ((> j maxrow))
733        (declare (fixnum j))
734        (display-hidden-info (aref *cells* i j))))))
735   
736(defun display-hidden-info (cell)
737  (case (cell-buttonstate cell)
738    (:button-down
739     (#_gtk_toggle_button_set_active (cell-button cell) #$TRUE))
740    (:button-flagged
741     (#_gtk_toggle_button_set_active (cell-button cell) #$FALSE))
742    (t
743     (setf (cell-buttonstate cell) :button-down)
744     (#_gtk_toggle_button_set_active (cell-button cell) #$TRUE)
745     (setf (pref (cell-button cell) :<G>tk<B>utton.button_down) #$TRUE)
746     (if (cell-has-bomb cell)
747       (add-image-to-mine cell *xpm-bomb*)
748       (let* ((nearby-bombs (cell-bombsnearby cell)))
749         (declare (fixnum nearby-bombs))
750         (if (> nearby-bombs 0)
751           (add-image-to-mine cell (svref *digits* nearby-bombs))
752           (open-nearby-squares (cell-col cell) (cell-row cell))))))))
753
754(defun show-bombs ()
755  (dotimes (i *ncols*)
756    (dotimes (j *nrows*)
757      (let* ((cell (aref *cells* i j))
758             (buttonstate (cell-buttonstate cell))
759             (has-bomb (cell-has-bomb cell)))
760        (if (and (eq buttonstate :button-unknown) has-bomb)
761          (display-hidden-info cell)
762          (when (and (eq buttonstate :button-flagged) (not has-bomb))
763            (free-children (cell-button cell))
764            (add-image-to-mine cell *xpm-bigx*)))))))
765
766             
767 
768(defcallback cell-toggled (:address widget :address data :void)
769  (let* ((cell (cell-id->cell data))
770         (state (cell-buttonstate cell)))
771    (unless (eq state :button-flagged)
772      (if *bgameover*
773        (#_gtk_toggle_button_set_active widget
774                                        (if (eq state
775                                                :button-down)
776                                          #$TRUE
777                                          #$FALSE))
778        (unless *bresetgame*
779          (start-timer)
780          (cond ((cell-has-bomb cell)
781                 (setq *bgameover* t)
782                 (set-start-button-icon *xpm-frown*)
783                 (stop-timer)
784                 (show-bombs))
785                (t
786                 (display-hidden-info cell)
787                 (check-for-win))))))))
788
789
790
791(defcallback button-press (:address widget :address event :address data :void)
792  (unless *bgameover*
793    (when (and (eql (pref event :<G>dk<E>vent<B>utton.type) #$GDK_BUTTON_PRESS)
794               (eql (pref event :<G>dk<E>vent<B>utton.button) 3))
795      (let* ((cell (cell-id->cell data)))
796        (case (cell-buttonstate cell)
797          (:button-unknown
798           (free-children widget)
799           (setf (cell-buttonstate cell) :button-flagged)
800           (add-image-to-mine cell *xpm-flag*)
801           (decf *nbombsleft*))
802          (:button-flagged
803           (free-children widget)
804           (setf (cell-buttonstate cell) :button-unknown)
805           (incf *nbombsleft*)))
806        (display-bomb-count)
807        (check-for-win)))))
808
809
810
811
812(defun set-start-button-icon (xpm-list)
813  (let* ((widget (create-widget-from-xpm *start-button* xpm-list)))
814    (free-children *start-button*)
815    (#_gtk_container_add *start-button* widget)))
816   
817(defun check-for-win ()
818  (let* ((nmines 0))
819    (declare (fixnum nmines))
820    (dotimes (col *ncols*)
821      (declare (fixnum col))
822      (dotimes (row *nrows*)
823        (declare (fixnum row))
824        (when (member (cell-buttonstate (aref *cells* col row))
825                      '(:button-unknown :button-flagged))
826          (incf nmines))))
827    (when (= nmines (the fixnum *ntotalbombs*))
828      (stop-timer)
829      (set-start-button-icon *xpm-winner*)
830      (setq *bgameover* t))))
831
832
833(defun create-button (table cell row column)
834  (let* ((button
835          (if *minesweeper-use-quiet-toggle-buttons*
836            (let* ((b (gtk-quiet-toggle-button-new))
837                   (id (cell->cell-id (aref *cells* column row))))
838              (with-cstrs ((cell-id "cell-id"))
839                (#_gtk_object_set_data b cell-id (%int-to-ptr id)))
840              b)
841            (#_gtk_toggle_button_new)))
842         (cell-id (cell->cell-id cell)))
843    (with-cstrs ((toggled "toggled")
844                 (button-press-event "button_press_event"))
845      (#_gtk_signal_connect_full button toggled cell-toggled
846                                 (%null-ptr) (%int-to-ptr cell-id) (%null-ptr) 0 0)
847      (#_gtk_signal_connect_full button button-press-event
848                            button-press (%null-ptr) (%int-to-ptr cell-id) (%null-ptr) 0 0))
849    (#_gtk_table_attach table button
850                        column (1+ column)
851                        (1+ row) (+ row 2)
852                        (logior #$GTK_FILL #$GTK_EXPAND)
853                        (logior #$GTK_FILL #$GTK_EXPAND)
854                        0 0)
855    (#_gtk_widget_set_usize button button-width button-height)
856    (#_gtk_widget_show button)
857    button))
858
859   
860(defun count-nearby-bombs (col row)
861  (declare (fixnum col row))
862  (let* ((mincol (max (1- col) 0))
863         (maxcol (min (1+ col) (1- *ncols*)))
864         (minrow (max (1- row) 0))
865         (maxrow (min (1+ row) (1- *nrows*)))
866         (ncount 0))
867    (declare (fixnum mincol maxcol minrow maxrow ncount))
868    (do* ((i mincol (1+ i)))
869         ((> i maxcol) ncount)
870      (declare (fixnum i))
871      (do* ((j minrow (1+ j)))
872           ((> j maxrow))
873        (declare (fixnum j))
874        (if (cell-has-bomb (aref *cells* i j))
875          (incf ncount))))))
876
877(defun display-bomb-count ()
878  (with-cstrs ((buf (format nil "Bombs: ~d" *nbombsleft*)))
879    (#_gtk_label_set_text *bombs-label* buf)))
880
881(defun update-seconds (seconds)
882  (with-cstrs ((buf (format nil "Time: ~d" seconds)))
883    (#_gtk_label_set_text *time-label* buf)))
884 
885(defun create-minesweeper-buttons (table ngridcols ngridrows bnewbuttons)
886  (setq *nrows* ngridrows
887        *ncols* ngridcols
888        *bgameover* nil
889        *bresetgame* t)
890  (display-bomb-count)
891  (dotimes (ci *ncols*)
892    (declare (fixnum ci))
893    (dotimes (ri *nrows*)
894      (declare (fixnum ri))
895      (let* ((cell (aref *cells* ci ri)))
896        (setf (cell-has-bomb cell) nil
897              (cell-buttonstate cell) :button-unknown)
898        (if bnewbuttons
899          (setf (cell-button cell) (create-button table cell ri ci))
900          (progn
901            (free-children (cell-button cell))
902            (#_gtk_toggle_button_set_active (cell-button cell) #$FALSE))))))
903  (do* ((nbombs *ntotalbombs*)
904        (state (make-random-state t)))
905       ((zerop nbombs))
906    (declare (fixnum nbombs))
907    (let* ((cell (aref *cells* (random *ncols* state) (random *nrows* state))))
908      (unless (cell-has-bomb cell)
909        (setf (cell-has-bomb cell) t)
910        (decf nbombs))))
911  (dotimes (ci *ncols*)
912    (declare (fixnum ci))
913    (dotimes (ri *nrows*)
914      (declare (fixnum ri))
915      (setf (cell-bombsnearby (aref *cells* ci ri))
916            (count-nearby-bombs ci ri))))
917  (setq *bresetgame* nil))
918                   
919(defun reset-game (ncols nrows nbombs bnewbuttons)
920  (setq *ntotalbombs* nbombs
921        *nbombsleft* nbombs)
922  (create-minesweeper-buttons *table* ncols nrows bnewbuttons)
923  (stop-timer)
924  (update-seconds 0)
925  (set-start-button-icon *xpm-smile*))
926
927
928             
929;;; Timer stuff.
930
931(defvar *timer* nil)
932(defvar *nseconds* 0)
933
934(defcallback timer-callback (:address data :void)
935  (declare (ignore data))
936  (incf *nseconds*)
937  (update-seconds *nseconds*))
938
939(defun start-timer ()
940  (unless *timer*
941    (setq *nseconds* 0
942          *timer* (#_gtk_timeout_add 1000 timer-callback *win-main*))))
943
944(defun stop-timer ()
945  (when *timer*
946    (#_gtk_timeout_remove *timer*)
947    (setq *timer* nil)))
948
949
950;;; Finally ...
951
952(defun minesweeper ()
953  (when *win-main*
954    (cerror
955     "Close current minesweeper game and start a new one"
956     "It seems that a minesweeper game is already active.")
957    (do* ()
958         ((null *win-main*))
959      (#_gtk_widget_destroy *win-main*)
960      (sleep 1)))
961  (let* ((window (#_gtk_window_new #$GTK_WINDOW_TOPLEVEL)))
962    (#_gtk_window_set_policy window #$FALSE #$FALSE #$TRUE)
963    (with-cstrs ((window-title "Minesweeper"))
964      (#_gtk_window_set_title window window-title)
965      (setq *vbox* (#_gtk_vbox_new #$FALSE 1))
966      (#_gtk_widget_show *vbox*)
967      (create-menu window *vbox*)
968      (let* ((hbox (#_gtk_hbox_new #$TRUE 1)))
969        (#_gtk_widget_show hbox)
970        (#_gtk_box_pack_start *vbox* hbox #$FALSE #$FALSE 0)
971        (with-cstrs ((len0-string ""))
972          (setq *bombs-label* (#_gtk_label_new len0-string)
973                *time-label* (#_gtk_label_new len0-string)))
974        (#_gtk_box_pack_start hbox *bombs-label* #$FALSE #$FALSE 0)
975        (#_gtk_widget_show *bombs-label*)
976        (setq *start-button* (#_gtk_button_new))
977        (with-cstrs ((clicked "clicked"))
978          (#_gtk_signal_connect_full *start-button* clicked start-button-clicked
979                                (%null-ptr) (%null-ptr) (%null-ptr) 0 0))
980        (#_gtk_box_pack_start hbox *start-button* #$FALSE #$FALSE 0)
981        (#_gtk_widget_show *start-button*)
982        (#_gtk_box_pack_start hbox *time-label* #$FALSE #$FALSE 0)
983        (#_gtk_widget_show *time-label*)
984        (#_gtk_widget_show hbox)
985        (#_gtk_container_add window *vbox*)
986        (with-cstrs ((destroy "destroy"))
987          (#_gtk_signal_connect_full window destroy action-quit (%null-ptr) window (%null-ptr) 0 0))
988        (#_gtk_widget_show window)
989
990        (set-start-button-icon *xpm-smile*)
991        (set-grid 10 10 10)))))
Note: See TracBrowser for help on using the repository browser.