/tic-tac-toe.scm
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)