guile-pstk

A Tk interface for Guile (A fork of (and hopefully a future merge?) https://github.com/kikyTokamuro/guile-pstk/).
Log | Files | Refs | README | LICENSE

ttt.scm (3565B)

      1 ; PS/Tk Example Program Tic Tac Toe
      2 ; Copyright (C) 2021-2022 Daniil Archangelsky aka Kiky Tokamuro
      3 ; Copyright (C) 2006 Nils M Holm
      4 ; See the PS/Tk license for conditions of use.
      5 
      6 (add-to-load-path
      7  (string-append
      8   (dirname (current-filename))
      9   "/../"))
     10 
     11 (use-modules (pstk))
     12 
     13 (define Font "Courier 30")
     14 
     15 (define Field (vector '_ '_ '_
     16                       '_ '_ '_
     17                       '_ '_ '_))
     18 
     19 (define Buttons #f)
     20 (define Qbutton #f)
     21 
     22 (define Lost #f)
     23 
     24 (define Moves '(((_ o o)  (o o o)) 
     25                 ((o _ o)  (o o o)) 
     26 		((o o _)  (o o o)) 
     27 		((_ x x)  (o x x)) 
     28 		((x _ x)  (x o x)) 
     29 		((x x _)  (x x o)) 
     30 		((_ x _)  (o x _)) 
     31 		((_ _ x)  (_ o x)) 
     32 		((x _ _)  (x o _)) 
     33 		((_ x o)  (o x o)) 
     34 		((_ o x)  (o o x)) 
     35 		((x _ o)  (x o o)) 
     36 		((x o _)  (x o o)) 
     37 		((o _ x)  (o o x)) 
     38 		((o x _)  (o x o)) 
     39 		((_ _ o)  (o _ o)) 
     40 		((o _ _)  (o _ o)) 
     41 		((_ _ _)  (_ o _))))
     42 
     43 (define pattern car)
     44 (define subst cadr)
     45 
     46 (define (match-row f1 f2 f3 rule)
     47   (cond ((and (eq? (vector-ref Field f1) (car (pattern rule)))
     48               (eq? (vector-ref Field f2) (cadr (pattern rule)))
     49               (eq? (vector-ref Field f3) (caddr (pattern rule))))
     50 	 (let ((new (subst rule)))
     51            (vector-set! Field f1 (car new))
     52            (vector-set! Field f2 (cadr new))
     53            (vector-set! Field f3 (caddr new))
     54            new))
     55 	(else #f)))
     56 
     57 (define (try-moves rules)
     58   (cond ((null? rules) '())
     59 	(else (let ((done (or (match-row 0 4 8 (car rules))
     60                               (match-row 2 4 6 (car rules))
     61                               (match-row 0 1 2 (car rules))
     62                               (match-row 3 4 5 (car rules))
     63                               (match-row 6 7 8 (car rules))
     64                               (match-row 0 3 6 (car rules))
     65                               (match-row 1 4 7 (car rules))
     66                               (match-row 2 5 8 (car rules)))))
     67 		(cond (done
     68                        (cond ((equal? done '(o o o))
     69 			      (set! Lost #t)
     70 			      (Qbutton 'configure 'text: "Oops!"
     71 				       'fg: "#ff0000"))))
     72 		      (else (try-moves (cdr rules))))))))
     73 
     74 (define (paint-field)
     75   (map (lambda (b p)
     76          (cond ((eq? p 'o)
     77 		(b 'configure 'text: "O" 'fg: 'blue
     78                    'activeforeground: 'blue))
     79                ((eq? p 'x)
     80 		(b 'configure 'text: "X" 'fg: 'red
     81                    'activeforeground: 'red))))
     82        Buttons (vector->list Field)))
     83 
     84 (define (move new)
     85   (cond ((and (not Lost)
     86               (eq? '_ (vector-ref Field new)))
     87 	 (vector-set! Field new 'x)
     88 	 (cond ((eq? '_ (vector-ref Field 4))
     89 		(vector-set! Field 4 'o))
     90                (else (try-moves Moves)))
     91 	 (paint-field)))
     92   '())
     93 
     94 (tk-start)
     95 (tk/wm 'title tk "Tic Tac Toe")
     96 
     97 (let* ((field
     98         (lambda (parent n)
     99           (parent 'create-widget 'button
    100                   'text: n 'font: Font
    101                   'fg: "#a0a0a0"
    102                   'bg: "#e0e0e0"
    103                   'command: (lambda () (move (- n 1))))))
    104        (row
    105         (lambda (n)
    106           (let* ((f (tk 'create-widget 'frame))
    107                  (b1 (field f n))
    108                  (b2 (field f (+ 1 n)))
    109                  (b3 (field f (+ 2 n))))
    110             (tk/pack b1 b2 b3 'side: 'left)
    111             (list f b1 b2 b3))))
    112        (r1 (row 1))
    113        (r2 (row 4))
    114        (r3 (row 7)))
    115   (tk/pack (car r1) (car r2) (car r3) 'side: 'top)
    116   (set! Buttons (append (cdr r1) (cdr r2) (cdr r3)))
    117   (set! Qbutton (tk 'create-widget 'button
    118                     'text: "Quit"
    119                     'command: tk-end))
    120   (tk/pack Qbutton 'side: 'top 'expand: #t 'fill: 'x)
    121   (tk-event-loop))