-
Notifications
You must be signed in to change notification settings - Fork 0
/
ttt.scm
121 lines (107 loc) · 3.48 KB
/
ttt.scm
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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
; PS/Tk Example Program Tic Tac Toe
; Copyright (C) 2021-2022 Daniil Archangelsky aka Kiky Tokamuro
; Copyright (C) 2006 Nils M Holm
; See the PS/Tk license for conditions of use.
(add-to-load-path
(string-append
(dirname (current-filename))
"/../"))
(use-modules (pstk))
(define Font "Courier 30")
(define Field (vector '_ '_ '_
'_ '_ '_
'_ '_ '_))
(define Buttons #f)
(define Qbutton #f)
(define Lost #f)
(define Moves '(((_ o o) (o o o))
((o _ o) (o o o))
((o o _) (o o o))
((_ x x) (o x x))
((x _ x) (x o x))
((x x _) (x x o))
((_ x _) (o x _))
((_ _ x) (_ o x))
((x _ _) (x o _))
((_ x o) (o x o))
((_ o x) (o o x))
((x _ o) (x o o))
((x o _) (x o o))
((o _ x) (o o x))
((o x _) (o x o))
((_ _ o) (o _ o))
((o _ _) (o _ o))
((_ _ _) (_ o _))))
(define pattern car)
(define subst cadr)
(define (match-row f1 f2 f3 rule)
(cond ((and (eq? (vector-ref Field f1) (car (pattern rule)))
(eq? (vector-ref Field f2) (cadr (pattern rule)))
(eq? (vector-ref Field f3) (caddr (pattern rule))))
(let ((new (subst rule)))
(vector-set! Field f1 (car new))
(vector-set! Field f2 (cadr new))
(vector-set! Field f3 (caddr new))
new))
(else #f)))
(define (try-moves rules)
(cond ((null? rules) '())
(else (let ((done (or (match-row 0 4 8 (car rules))
(match-row 2 4 6 (car rules))
(match-row 0 1 2 (car rules))
(match-row 3 4 5 (car rules))
(match-row 6 7 8 (car rules))
(match-row 0 3 6 (car rules))
(match-row 1 4 7 (car rules))
(match-row 2 5 8 (car rules)))))
(cond (done
(cond ((equal? done '(o o o))
(set! Lost #t)
(Qbutton 'configure 'text: "Oops!"
'fg: "#ff0000"))))
(else (try-moves (cdr rules))))))))
(define (paint-field)
(map (lambda (b p)
(cond ((eq? p 'o)
(b 'configure 'text: "O" 'fg: 'blue
'activeforeground: 'blue))
((eq? p 'x)
(b 'configure 'text: "X" 'fg: 'red
'activeforeground: 'red))))
Buttons (vector->list Field)))
(define (move new)
(cond ((and (not Lost)
(eq? '_ (vector-ref Field new)))
(vector-set! Field new 'x)
(cond ((eq? '_ (vector-ref Field 4))
(vector-set! Field 4 'o))
(else (try-moves Moves)))
(paint-field)))
'())
(tk-start)
(tk/wm 'title tk "Tic Tac Toe")
(let* ((field
(lambda (parent n)
(parent 'create-widget 'button
'text: n 'font: Font
'fg: "#a0a0a0"
'bg: "#e0e0e0"
'command: (lambda () (move (- n 1))))))
(row
(lambda (n)
(let* ((f (tk 'create-widget 'frame))
(b1 (field f n))
(b2 (field f (+ 1 n)))
(b3 (field f (+ 2 n))))
(tk/pack b1 b2 b3 'side: 'left)
(list f b1 b2 b3))))
(r1 (row 1))
(r2 (row 4))
(r3 (row 7)))
(tk/pack (car r1) (car r2) (car r3) 'side: 'top)
(set! Buttons (append (cdr r1) (cdr r2) (cdr r3)))
(set! Qbutton (tk 'create-widget 'button
'text: "Quit"
'command: tk-end))
(tk/pack Qbutton 'side: 'top 'expand: #t 'fill: 'x)
(tk-event-loop))