PageRenderTime 111ms CodeModel.GetById 93ms app.highlight 16ms RepoModel.GetById 0ms app.codeStats 0ms

/tic-tac-toe.scm

http://srcc.googlecode.com/
Scheme | 252 lines | 223 code | 2 blank | 27 comment | 0 complexity | d48ddae5a500b122a6654a88c3c4bfb0 MD5 | raw file
  1;  tic-tac-toe.ss
  2;
  3;  Copyright (c) 2010-2011  Mikhail Mosienko  <netluxe@gmail.com>
  4;
  5;  Permission is hereby granted, free of charge, to any person obtaining a copy
  6;  of this software and associated documentation files (the "Software"), to deal
  7;  in the Software without restriction, including without limitation the rights
  8;  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  9;  copies of the Software, and to permit persons to whom the Software is
 10;  furnished to do so, subject to the following conditions:
 11;
 12;  The above copyright notice and this permission notice shall be included in
 13;  all copies or substantial portions of the Software.
 14;
 15;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 16;  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 17;  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
 18;  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
 19;  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
 20;  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
 21;  THE SOFTWARE.
 22;
 23
 24(define (tic-tac-toe)
 25  (letrec ((area
 26            '((0-0 . #f) (0-1 . #f) (0-2 . #f)
 27                         (1-0 . #f) (1-1 . #f) (1-2 . #f)
 28                         (2-0 . #f) (2-1 . #f) (2-2 . #f)))
 29           (figure?
 30            (lambda(f)
 31              (if (or (eq? f 0)
 32                      (eq? f 'x)) #t #f)))
 33           (position?
 34            (lambda(p)
 35              (let ((pos (assq p area)))
 36                (if (and pos
 37                         (not (cdr pos))) p #f))))
 38           (clear-area
 39            (lambda()
 40              (for-each
 41               (lambda(p)
 42                 (set-cdr! p #f))
 43               area)))
 44           (user-figure #f)
 45           (cpu-figure #f)
 46           (end-game?
 47            (lambda(v)
 48              (cond
 49                ((and (eq? (cdr (assq '0-0 area)) v)
 50                      (eq? (cdr (assq '0-1 area)) v)
 51                      (eq? (cdr (assq '0-2 area)) v)) #t)
 52                ((and (eq? (cdr (assq '1-0 area)) v)
 53                      (eq? (cdr (assq '1-1 area)) v)
 54                      (eq? (cdr (assq '1-2 area)) v)) #t)
 55                ((and (eq? (cdr (assq '2-0 area)) v)
 56                      (eq? (cdr (assq '2-1 area)) v)
 57                      (eq? (cdr (assq '2-2 area)) v)) #t)
 58                ((and (eq? (cdr (assq '0-0 area)) v)
 59                      (eq? (cdr (assq '1-0 area)) v)
 60                      (eq? (cdr (assq '2-0 area)) v)) #t)
 61                ((and (eq? (cdr (assq '0-1 area)) v)
 62                      (eq? (cdr (assq '1-1 area)) v)
 63                      (eq? (cdr (assq '2-1 area)) v)) #t)
 64                ((and (eq? (cdr (assq '0-2 area)) v)
 65                      (eq? (cdr (assq '1-2 area)) v)
 66                      (eq? (cdr (assq '2-2 area)) v)) #t)
 67                ((and (eq? (cdr (assq '0-0 area)) v)
 68                      (eq? (cdr (assq '1-1 area)) v)
 69                      (eq? (cdr (assq '2-2 area)) v)) #t)
 70                ((and (eq? (cdr (assq '0-2 area)) v)
 71                      (eq? (cdr (assq '1-1 area)) v)
 72                      (eq? (cdr (assq '2-0 area)) v)) #t)
 73                (else #f))))
 74           (set-user-figure
 75            (lambda()
 76              (display "???????? ??????? ??? ????? (x ??? 0): ")
 77              (let ((f (read)))
 78                (if (figure? f)
 79                    (set! user-figure f)
 80                    (begin
 81                      (newline)
 82                      (set-user-figure))))))
 83           (set-cpu-figure
 84            (lambda()
 85              (if (eq? user-figure 'x)
 86                  (set! cpu-figure 0)
 87                  (set! cpu-figure 'x))))
 88           (get-move
 89            (lambda()
 90              (display "??? ???: ")
 91              (let ((p (read)))
 92                (if (position? p)
 93                    (set-cdr! (assq p area) user-figure)
 94                    (begin
 95                      (newline)
 96                      (get-move))))))
 97           (print-cage
 98            (lambda()
 99              (let ((get-value
100                     (lambda(p)
101                       (let ((val (cdr (assq p area))))
102                         (if val val #\space)))))
103                (display "  0 1 2\n")
104                (display "0 ") (display (get-value '0-0)) (display "|")
105                (display (get-value '0-1)) (display "|") (display (get-value '0-2))
106                (newline)
107                (display " -------") (newline)
108                (display "1 ") (display (get-value '1-0)) (display "|")
109                (display (get-value '1-1)) (display "|") (display (get-value '1-2))
110                (newline)
111                (display " -------") (newline)
112                (display "2 ") (display (get-value '2-0)) (display "|")
113                (display (get-value '2-1)) (display "|") (display (get-value '2-2))
114                (newline))))
115           (find-move
116            (lambda()
117              (let ((lines
118                     (list
119                      (cons
120                       (list '0-0 '0-1 '0-2)
121                       (list (cdr (assq '0-0 area)) (cdr (assq '0-1 area)) (cdr (assq '0-2 area))))
122                      (cons
123                       (list '1-0 '1-1 '1-2)
124                       (list (cdr (assq '1-0 area)) (cdr (assq '1-1 area)) (cdr (assq '1-2 area))))
125                      (cons
126                       (list '2-0 '2-1 '2-2)
127                       (list (cdr (assq '2-0 area)) (cdr (assq '2-1 area)) (cdr (assq '2-2 area))))
128                      (cons
129                       (list '0-0 '1-0 '2-0)
130                       (list (cdr (assq '0-0 area)) (cdr (assq '1-0 area)) (cdr (assq '2-0 area))))
131                      (cons
132                       (list '0-1 '1-1 '2-1)
133                       (list (cdr (assq '0-1 area)) (cdr (assq '1-1 area)) (cdr (assq '2-1 area))))
134                      (cons
135                       (list '0-2 '1-2 '2-2)
136                       (list (cdr (assq '0-2 area)) (cdr (assq '1-2 area)) (cdr (assq '2-2 area))))
137                      (cons
138                       (list '0-0 '1-1 '2-2)
139                       (list (cdr (assq '0-0 area)) (cdr (assq '1-1 area)) (cdr (assq '2-2 area))))
140                      (cons
141                       (list '2-0 '1-1 '0-2)
142                       (list (cdr (assq '2-0 area)) (cdr (assq '1-1 area)) (cdr (assq '0-2 area)))))))
143                (call-with-current-continuation
144                 (lambda (return)
145                   ; check win positions
146                   (for-each
147                    (lambda(l)
148                      (cond
149                        ((equal? (cdr l) `(,cpu-figure ,cpu-figure #f))
150                         (return (caddr (car l))))
151                        ((equal? (cdr l) `(,cpu-figure #f ,cpu-figure))
152                         (return (cadr (car l))))
153                        ((equal? (cdr l) `(#f ,cpu-figure ,cpu-figure))
154                         (return (car (car l))))))
155                    lines)
156                   ; check user positions
157                   (for-each
158                    (lambda(l)
159                      (cond
160                        ((equal? (cdr l) `(,user-figure ,user-figure #f))
161                         (return (caddr (car l))))
162                        ((equal? (cdr l) `(,user-figure #f ,user-figure))
163                         (return (cadr (car l))))
164                        ((equal? (cdr l) `(#f ,user-figure ,user-figure))
165                         (return (car (car l))))))
166                    lines)
167                   (if (equal? (cdr (assoc '(0-0 0-1 0-2) lines)) `( #f ,user-figure #f))
168                       (cond
169                         ((equal? (cdr (assoc '(0-0 1-0 2-0) lines)) `( #f ,user-figure #f))
170                          (return '0-0))
171                         ((equal? (cdr (assoc '(0-2 1-2 2-2) lines)) `( #f ,user-figure #f))
172                          (return '0-2))))
173                   (if (equal? (cdr (assoc '(0-0 1-0 2-0) lines)) `( #f ,user-figure #f))
174                       (cond
175                         ((equal? (cdr (assoc '(0-0 0-1 0-2) lines)) `( #f ,user-figure #f))
176                          (return '0-0))
177                         ((equal? (cdr (assoc '(2-0 2-1 2-2) lines)) `( #f ,user-figure #f))
178                          (return '2-0))))
179                   (if (equal? (cdr (assoc '(2-0 2-1 2-2) lines)) `( #f ,user-figure #f))
180                       (cond
181                         ((equal? (cdr (assoc '(0-2 1-2 2-2) lines)) `( #f ,user-figure #f))
182                          (return '2-2))
183                         ((equal? (cdr (assoc '(0-0 1-0 2-0) lines)) `( #f ,user-figure #f))
184                          (return '2-0))))
185                   (if (equal? (cdr (assoc '(0-2 1-2 2-2) lines)) `( #f ,user-figure #f))
186                       (cond
187                         ((equal? (cdr (assoc '(2-0 2-1 2-2) lines)) `( #f ,user-figure #f))
188                          (return '2-2))
189                         ((equal? (cdr (assoc '(0-0 0-1 0-2) lines)) `( #f ,user-figure #f))
190                          (return '0-2))))
191                   ; check second positions
192                   (for-each
193                    (lambda(l)
194                      (cond
195                        ((equal? (cdr l) `(,cpu-figure #f #f))
196                         (return (caddr (car l))))
197                        ((equal? (cdr l) `(#f #f ,cpu-figure))
198                         (return (car (car l))))
199                        ((equal? (cdr l) `(#f ,cpu-figure #f))
200                         (return (car (car l))))))
201                    lines)
202                   ; find empty position
203                   (if (not (cdr (assq '1-1 area)))
204                       (return '1-1))
205                   (for-each
206                    (lambda(l)
207                      (if (not (cdr l))
208                          (return (car l))))
209                    area)
210                   #f)))))
211           (game
212            (lambda()
213              (call-with-current-continuation
214               (lambda (return)
215                 (if (or (end-game? cpu-figure)
216                         (end-game? user-figure))
217                     (return))
218                 (if (eq? user-figure 'x)
219                     (begin
220                       (print-cage)
221                       (get-move)
222                       (if (end-game? user-figure)
223                           (return)
224                           (let ((m (find-move)))
225                             (if m
226                                 (set-cdr! (assq m area) cpu-figure)
227                                 (return)))))
228                     (begin
229                       (set-cdr! (assq (find-move) area) cpu-figure)
230                       (print-cage)
231                       (if (or (end-game? cpu-figure)
232                               (not (find-move)))
233                           (return)
234                           (get-move))))
235                 (game)))))
236           )
237    (clear-area)
238    (set-user-figure)
239    (set-cpu-figure)
240    (display "??? ??? ????? ??? {? ??????}-{? ???????}\n????????, 1-2, 1-1, 2-0.\n")
241    (game)
242    (display "------------------------\n")
243    (print-cage)
244    (cond
245      ((end-game? cpu-figure)
246       (display "?? ?????????!"))
247      ((end-game? user-figure)
248       (display "?? ????????!"))
249      (else
250       (display "?????!")))))
251
252;(tic-tac-toe)