commit 9c0cf13c0580d8bb1f99581694f30e19fc624d07 parent 5032c966804cb7d7ec38f902aadbaf7fa632a731 Author: KikyTokamuro <kiky.tokamuro@yandex.ru> Date: Wed, 1 Dec 2021 21:31:56 +0300 Added tic tac toe example Diffstat:
| A | examples/ttt.scm | | | 117 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
1 file changed, 117 insertions(+), 0 deletions(-)
diff --git a/examples/ttt.scm b/examples/ttt.scm @@ -0,0 +1,117 @@ +; PS/Tk Example Program Tic Tac Toe +; Copyright (C) 2021 Daniil Archangelsky aka Kiky Tokamuro +; Copyright (C) 2006 Nils M Holm +; See the PS/Tk license for conditions of use. + +(load "../pstk.scm") + +(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 _ _) (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))