File: tictactoe.scm

package info (click to toggle)
guile-gtk-1.2 0.31-3
  • links: PTS
  • area: main
  • in suites: sarge
  • size: 2,544 kB
  • ctags: 2,413
  • sloc: sh: 11,073; ansic: 3,380; lisp: 1,058; makefile: 106
file content (49 lines) | stat: -rw-r--r-- 1,417 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
(read-set! keywords 'prefix)

(use-modules (gtk gtk))

(define tictactoe-new
  (let ((ttt-class (gtk-class-new 'GtkVBox "TicTacToe")))
    (gtk-signal-new-generic "tictactoe" '(first) ttt-class 'void '())
    (lambda ()
      (let* ((widget (gtk-widget-new ttt-class))
	     (table (gtk-table-new 3 3 #t))
	     (buttons (make-vector 9)))
	(define (ttt-clear)
	  (do ((p 0 (1+ p)))
	      ((>= p 9))
	    (gtk-widget-set (vector-ref buttons p) :active #f)))
	(define (ttt-toggle)
	  (let loop ((wins '((0 1 2) (3 4 5) (6 7 8)
			     (0 3 6) (1 4 7) (2 5 8)
			     (0 4 8) (2 4 6))))
	    (cond ((not (null? wins))
		   (cond ((and-map (lambda (wp) 
				     (gtk-widget-get (vector-ref buttons wp)
						     :active))
				   (car wins))
			  (gtk-signal-emit widget "tictactoe")
			  (ttt-clear))
			 (else
			  (loop (cdr wins))))))))
	    
	(do ((p 0 (1+ p)))
	    ((>= p 9))
	  (let ((b (gtk-toggle-button-new))
		(i (quotient p 3))
		(j (remainder p 3)))
	    (vector-set! buttons p b)
	    (gtk-table-attach-defaults table b i (1+ i) j (1+ j))
	    (gtk-signal-connect b "toggled" ttt-toggle)
	    (gtk-widget-set-usize b 20 20)))
	(gtk-container-add widget table)
	(gtk-widget-show-all widget)
	widget))))

(define w (gtk-window-new 'toplevel))
(define ttt (tictactoe-new))
(gtk-container-add w ttt)
(gtk-widget-show-all w)
(gtk-signal-connect ttt "tictactoe" (lambda () (pk 'Yay)))

(gtk-standalone-main w)