666 lines
18 KiB
Plaintext
666 lines
18 KiB
Plaintext
![]() |
#!/bin/sh
|
||
|
:; exec /usr/local/bin/stk -f "$0" "$@"
|
||
|
;;;
|
||
|
;;; 3D Tic-Tac-Toe
|
||
|
;;; written by Edin "Dino" Hodzic
|
||
|
;;; mailto:ehodzic@scu.edu
|
||
|
|
||
|
;;; last update: Jun 30, 1996.
|
||
|
|
||
|
;;; This is a free program written for STk 3.0.
|
||
|
|
||
|
;;; GUI related variables
|
||
|
|
||
|
; sizes and positions
|
||
|
(define cell-width 15)
|
||
|
(define cell-height 15)
|
||
|
(define distance 15) ; vertical between planes
|
||
|
(define x0 distance)
|
||
|
(define y0 distance)
|
||
|
(define modx0 0) ; actual x0
|
||
|
(define mody0 0) ; actual y0
|
||
|
(define angle 45) ; plane drawing angle
|
||
|
(define delx 0) ; x change from row to row
|
||
|
(define dely 0) ; y change from row to row
|
||
|
|
||
|
; colors
|
||
|
(if (eq? (winfo 'visual '.) 'staticgray)
|
||
|
(begin
|
||
|
(define grid-color 'black)
|
||
|
(define sign-color 'black)
|
||
|
(define win-sign-color 'black)
|
||
|
(define last-move-sign-color 'black)
|
||
|
(define show-line-color 'black))
|
||
|
(begin
|
||
|
(define grid-color 'white)
|
||
|
(define sign-color 'navy)
|
||
|
(define win-sign-color 'red)
|
||
|
(define last-move-sign-color 'blue)
|
||
|
(define show-line-color 'magenta)))
|
||
|
|
||
|
;;; GUI related functions
|
||
|
|
||
|
(define (set-angle! ang)
|
||
|
(set! angle ang)
|
||
|
(let* ((pi (* (atan 1) 4))
|
||
|
(rangle (* angle (/ pi 180))))
|
||
|
(set! delx (round (- (* cell-height (cos rangle)))))
|
||
|
(set! dely (round (* cell-height (sin rangle))))))
|
||
|
|
||
|
; draw a 4x4 plane with x0 y0 reference point (in the canvas)
|
||
|
(define (draw-plane x0 y0)
|
||
|
(for-each-5
|
||
|
(lambda (i)
|
||
|
(let* ((rowx1 (+ x0 (* delx i)))
|
||
|
(rowy1 (+ y0 (* dely i)))
|
||
|
(rowx2 (+ rowx1 (* cell-width 4)))
|
||
|
(rowy2 rowy1)
|
||
|
(colx1 (+ x0 (* cell-width i)))
|
||
|
(coly1 y0)
|
||
|
(colx2 (+ colx1 (* delx 4)))
|
||
|
(coly2 (+ y0 (* dely 4))))
|
||
|
(.board 'create 'line ; horizontal line
|
||
|
rowx1 rowy1
|
||
|
rowx2 rowy2
|
||
|
:fill grid-color
|
||
|
:width 1)
|
||
|
(.board 'create 'line ; vertical line
|
||
|
colx1 coly1
|
||
|
colx2 coly2
|
||
|
:fill grid-color
|
||
|
:width 1)
|
||
|
(if (= i 4)
|
||
|
(begin
|
||
|
(.board 'create 'line ; plane bottom horizontal line
|
||
|
rowx1 (+ 2 rowy1)
|
||
|
rowx2 (+ 2 rowy2)
|
||
|
:fill grid-color
|
||
|
:width 2)
|
||
|
(.board 'create 'line ; plane side vertical line
|
||
|
colx1 (+ 2 coly1)
|
||
|
colx2 (+ 2 coly2)
|
||
|
:fill grid-color
|
||
|
:width 2)))))))
|
||
|
|
||
|
; screen coordinates to point
|
||
|
(define (screenxy->point x y)
|
||
|
(let* ((canx (.board 'canvasx x))
|
||
|
(cany (.board 'canvasy y))
|
||
|
(x0 modx0)
|
||
|
(y0 mody0)
|
||
|
(plane (inexact->exact
|
||
|
(floor (/ (- cany y0)
|
||
|
(+ (* dely 4) distance)))))
|
||
|
(rowq (/ (- cany y0 (+ (* dely 4 plane) (* distance plane)))
|
||
|
dely))
|
||
|
(row (inexact->exact (floor rowq)))
|
||
|
(col (inexact->exact (floor
|
||
|
(/ (- canx (+ x0 (* delx rowq)))
|
||
|
cell-width)))))
|
||
|
(if (and (<= 0 plane 3) (<= 0 row 3) (<= 0 col 3))
|
||
|
(make-point plane row col)
|
||
|
#f)))
|
||
|
|
||
|
; north-west corner of a point to board screen coordinates
|
||
|
(define (point->screen point)
|
||
|
(let ((plane (point-plane point))
|
||
|
(row (point-row point))
|
||
|
(col (point-column point)))
|
||
|
(cons (inexact->exact (+ modx0 (* delx row)
|
||
|
(* cell-width col)))
|
||
|
(inexact->exact (+ mody0 (* plane dely 4)
|
||
|
(* row dely) (* plane distance))))))
|
||
|
|
||
|
; center of a point to board screen coordinates
|
||
|
(define (point->screen-center point)
|
||
|
(let* ((scr (point->screen point))
|
||
|
(x (inexact->exact (+ (car scr) (* cell-width 0.5) (* delx 0.5))))
|
||
|
(y (inexact->exact (+ (cdr scr) (* dely 0.5)))))
|
||
|
(cons x y)))
|
||
|
|
||
|
; the last point for which lines have been shown
|
||
|
(define shown-lines-point #f)
|
||
|
|
||
|
; line showing flag
|
||
|
(define show-lines-flag #f)
|
||
|
|
||
|
(define (show-lines point)
|
||
|
(if (and point (or (not shown-lines-point)
|
||
|
(not (point-equal? point shown-lines-point))))
|
||
|
(begin
|
||
|
(set! shown-lines-point point)
|
||
|
(.board 'delete "lines")
|
||
|
(for-each
|
||
|
(lambda (line)
|
||
|
(let* ((first (line 0))
|
||
|
(last (line 3))
|
||
|
(scr-first (point->screen-center first))
|
||
|
(scr-last (point->screen-center last)))
|
||
|
(.board 'create 'line ; draw the line
|
||
|
(car scr-first) (cdr scr-first)
|
||
|
(car scr-last) (cdr scr-last)
|
||
|
:tag "lines"
|
||
|
:width 0
|
||
|
:fill show-line-color)
|
||
|
(for-each-point-in-line ; mark the point thru which line goes
|
||
|
(lambda (point)
|
||
|
(let ((scr (point->screen-center point)))
|
||
|
(.board 'create 'text (car scr) (cdr scr)
|
||
|
:text "="
|
||
|
:tag "lines"
|
||
|
:fill show-line-color)))
|
||
|
line)))
|
||
|
(point-lines point))))
|
||
|
(if (not show-lines-flag)
|
||
|
(.board 'delete "lines")))
|
||
|
|
||
|
(define (toggle-show-lines point)
|
||
|
(set! show-lines-flag (not show-lines-flag))
|
||
|
(set! shown-lines-point #f)
|
||
|
(note (string-append "Line showing is " (if show-lines-flag "ON" "OFF")))
|
||
|
(show-lines point))
|
||
|
|
||
|
; show the move on the board
|
||
|
(define (draw-move point val . high)
|
||
|
(let* ((scr (point->screen-center point))
|
||
|
(x (car scr))
|
||
|
(y (cdr scr)))
|
||
|
(.board 'delete (point->string point))
|
||
|
(.board 'create 'text x y
|
||
|
:text (value->sign val)
|
||
|
:tag (point->string point)
|
||
|
:fill (cond
|
||
|
((or (null? high) (eq? (car high) 'plain)) sign-color)
|
||
|
((equal? (car high) 'highlight) win-sign-color)
|
||
|
((equal? (car high) 'last) last-move-sign-color)
|
||
|
(#t sign-color)))))
|
||
|
|
||
|
(define (clear-move point)
|
||
|
(.board 'delete (point->string point)))
|
||
|
|
||
|
; draw the 3D 4x4x4 board
|
||
|
(define (draw-board)
|
||
|
(catch (entry '.note :state 'disabled))
|
||
|
(catch (canvas '.board :relief 'sunken :borderwidth 2))
|
||
|
(catch
|
||
|
(menubutton '.mb :text "File")
|
||
|
(menu '.mb.m)
|
||
|
(.mb.m 'add 'command :label "New Game" :command new-game)
|
||
|
(.mb.m 'add 'command :label "Take Back" :command take-back-move)
|
||
|
(.mb.m 'add 'command :label "Toggle Lines"
|
||
|
:command (lambda () (toggle-show-lines #f)))
|
||
|
(.mb.m 'add 'command :label "Resize" :command tune)
|
||
|
(.mb.m 'add 'command :label "Quit" :command (lambda () (quit)))
|
||
|
(.mb 'config :menu '.mb.m))
|
||
|
(catch
|
||
|
(menubutton '.help :text "Help")
|
||
|
(menu '.help.m)
|
||
|
(.help.m 'add 'command :label "About" :command about)
|
||
|
(.help 'config :menu '.help.m))
|
||
|
(.board 'delete 'all)
|
||
|
(bind '.board "<1>" (lambda (x y) (action x y)))
|
||
|
(bind '.board "<2>" take-back-move)
|
||
|
(bind '.board "<3>" tune)
|
||
|
(bind '.board "<Any-Motion>"
|
||
|
(lambda (x y) (show-lines (screenxy->point x y))))
|
||
|
(bind '.board "<l>"
|
||
|
(lambda (x y) (toggle-show-lines (screenxy->point x y))))
|
||
|
(bind '.board "<L>"
|
||
|
(lambda (x y) (toggle-show-lines (screenxy->point x y))))
|
||
|
(bind '. "<Q>" (lambda () (quit)))
|
||
|
(bind '. "<q>" (lambda () (quit)))
|
||
|
(bind '. "<space>" new-game)
|
||
|
(bind '. "<m>" (lambda () (display moves) (newline)))
|
||
|
(focus '.board)
|
||
|
(for-each-4 ; draw plane
|
||
|
(lambda (i)
|
||
|
(draw-plane 0 (+ (* dely 4 i) (* distance i)))))
|
||
|
(let* ((bbox (.board 'bbox 'all))
|
||
|
(width (+ (- (caddr bbox) (car bbox)) x0 x0))
|
||
|
(height (+ (- (cadddr bbox) (cadr bbox)) y0 y0)))
|
||
|
(set! modx0 (- x0 (car bbox)))
|
||
|
(set! mody0 (- y0 (cadr bbox)))
|
||
|
(.board 'move 'all modx0 mody0)
|
||
|
(.board 'configure :width width :height height)
|
||
|
(pack '.note :expand #t :fill "x" :side 'bottom)
|
||
|
(pack '.board :expand #t :fill "both" :side 'bottom)
|
||
|
(pack '.mb :side 'left)
|
||
|
(pack '.help :side 'right))
|
||
|
(for-each-point1 ; draw point state sign
|
||
|
(lambda (point)
|
||
|
(let ((val (state-ref1 point)))
|
||
|
(if (not (= val empty-value))
|
||
|
(if (crosses? win-line point)
|
||
|
(draw-move point val 'highlight)
|
||
|
(if (or (and (not (null? moves))
|
||
|
(point-equal? (car moves) point))
|
||
|
(and (not (null? (cdr moves)))
|
||
|
(point-equal? (cadr moves) point)))
|
||
|
(draw-move point val 'last)
|
||
|
(draw-move point val)))))))
|
||
|
(let ((point shown-lines-point)) ; show lines if on
|
||
|
(set! shown-lines-point #f)
|
||
|
(show-lines point))
|
||
|
(note ""))
|
||
|
|
||
|
(define (about)
|
||
|
(catch (destroy .about))
|
||
|
(toplevel '.about)
|
||
|
(message '.about.m
|
||
|
:width 250
|
||
|
:justify 'center
|
||
|
:text
|
||
|
"3D Tic-Tac-Toe\n\
|
||
|
by\n\
|
||
|
Edin \"Dino\" Hodzic\n\
|
||
|
mailto:ehodzic@scu.edu")
|
||
|
(button '.about.ok :text "OK" :command (lambda () (destroy '.about)))
|
||
|
(pack '.about.m :expand #t :fill 'both :side 'top)
|
||
|
(pack '.about.ok :side 'top))
|
||
|
|
||
|
; reset the board size/angle
|
||
|
(define (tune-reset)
|
||
|
(set! cell-width 15)
|
||
|
(set! cell-height 15)
|
||
|
(set-angle! 45))
|
||
|
|
||
|
; show the resizing window
|
||
|
(define (tune)
|
||
|
(catch (destroy '.tune))
|
||
|
(toplevel '.tune)
|
||
|
(scale '.tune.cw
|
||
|
:label "Cell Width"
|
||
|
:variable 'cell-width
|
||
|
:command (lambda (v) (set-angle! angle) (draw-board))
|
||
|
:relief 'sunken
|
||
|
:orient 'horizontal)
|
||
|
(scale '.tune.ch
|
||
|
:label "Cell Height"
|
||
|
:variable 'cell-height
|
||
|
:command (lambda (v) (set-angle! angle) (draw-board))
|
||
|
:relief 'sunken
|
||
|
:orient 'horizontal)
|
||
|
(scale '.tune.an
|
||
|
:label "Angle"
|
||
|
:variable 'angle
|
||
|
:orient 'horizontal
|
||
|
:relief 'sunken
|
||
|
:to 180
|
||
|
:command (lambda (v) (set-angle! angle) (draw-board)))
|
||
|
(button '.tune.quit :text "Close"
|
||
|
:command (lambda () (destroy '.tune)))
|
||
|
(button '.tune.reset :text "Reset"
|
||
|
:command (lambda () (tune-reset) (draw-board)))
|
||
|
(pack '.tune.cw :fill 'x :side 'top)
|
||
|
(pack '.tune.ch :fill 'x :side 'top)
|
||
|
(pack '.tune.an :fill 'x :side 'top)
|
||
|
(pack '.tune.reset :fill 'x :side 'left)
|
||
|
(pack '.tune.quit :fill 'x :side 'right))
|
||
|
|
||
|
; highlight the winning line
|
||
|
(define (show-winning move)
|
||
|
(let ((val (state-ref1 move)))
|
||
|
(for-each-point-in-line ; draw highlighed point
|
||
|
(lambda (point)
|
||
|
(draw-move point val 'highlight))
|
||
|
win-line)
|
||
|
(note (string-append
|
||
|
"Game Over - "
|
||
|
(if (= val comp-value)
|
||
|
"I win!"
|
||
|
"You win!")))))
|
||
|
|
||
|
; show a note
|
||
|
(define (note str)
|
||
|
(.note 'config :state 'normal)
|
||
|
(.note 'delete 0 'end)
|
||
|
(.note 'insert 0 str)
|
||
|
(.note 'config :state 'disabled))
|
||
|
|
||
|
; clear up everything and restart the game
|
||
|
(define (new-game)
|
||
|
(clear-state!)
|
||
|
(set! game-over #f)
|
||
|
(set! win-line #f)
|
||
|
(set! moves '())
|
||
|
(draw-board))
|
||
|
|
||
|
;;; state and other game related variables
|
||
|
|
||
|
|
||
|
(define signs (vector #f "o" "x")) ; player signs
|
||
|
(define game-over #f) ; game over flag
|
||
|
(define win-line #f) ; the winning line
|
||
|
(define empty-value 0) ; available point value in the state
|
||
|
(define user-value 1) ; user value in the state vector
|
||
|
(define comp-value 2) ; compute value in the state vector
|
||
|
(define state #f) ; the board state
|
||
|
(define moves '()) ; the list of all moves played
|
||
|
|
||
|
;;; state access functions
|
||
|
|
||
|
(define (value->sign val)
|
||
|
(vector-ref signs val))
|
||
|
|
||
|
(define (state-ref p r c)
|
||
|
(let ((ind (inexact->exact (+ c (* 4 (+ r (* 4 p)))))))
|
||
|
(vector-ref state ind)))
|
||
|
|
||
|
(define (state-ref1 point)
|
||
|
(state-ref (point-plane point)
|
||
|
(point-row point)
|
||
|
(point-column point)))
|
||
|
|
||
|
(define (state-set! p r c v)
|
||
|
(let ((ind (inexact->exact (+ c (* 4 (+ r (* 4 p)))))))
|
||
|
(vector-set! state ind v)))
|
||
|
|
||
|
(define (state-set1! point val)
|
||
|
(state-set! (point-plane point)
|
||
|
(point-row point)
|
||
|
(point-column point) val))
|
||
|
|
||
|
(define (clear-state!)
|
||
|
(set! state (make-vector 64 empty-value)))
|
||
|
|
||
|
;;; playing functions
|
||
|
|
||
|
; entry point on user click
|
||
|
(define (action x y)
|
||
|
(let* ((user-move (screenxy->point x y)))
|
||
|
(if (and (not game-over) user-move)
|
||
|
(play user-move))))
|
||
|
|
||
|
(define (acceptable-move? move)
|
||
|
(and (not game-over)
|
||
|
(= (state-ref1 move) empty-value)))
|
||
|
|
||
|
; play with user's move
|
||
|
(define (play move)
|
||
|
(if (acceptable-move? move)
|
||
|
(begin
|
||
|
(note "")
|
||
|
(enter-move move user-value)
|
||
|
(if (won? move)
|
||
|
(show-winning move)
|
||
|
(let ((comp-move (make-move)))
|
||
|
(enter-move comp-move comp-value)
|
||
|
(if (won? comp-move)
|
||
|
(show-winning comp-move)
|
||
|
(if (draw?)
|
||
|
(note "It's a draw!"))))))
|
||
|
(note "Bad move")))
|
||
|
|
||
|
; change the state and draw the move on the board
|
||
|
(define (enter-move move val)
|
||
|
(if move
|
||
|
(begin
|
||
|
(state-set1! move val)
|
||
|
(set! moves (cons move moves))
|
||
|
(if (and
|
||
|
(not (null? (cdr moves)))
|
||
|
(not (null? (cddr moves))))
|
||
|
(begin
|
||
|
(clear-move (caddr moves))
|
||
|
(draw-move (caddr moves) val 'plain)))
|
||
|
(draw-move move val 'last)
|
||
|
(update 'idletasks))))
|
||
|
|
||
|
; take a move back
|
||
|
(define (take-back-move)
|
||
|
(if (null? moves)
|
||
|
(note "No more moves")
|
||
|
(let ((take-one
|
||
|
(lambda ()
|
||
|
(if (not (null? moves))
|
||
|
(begin
|
||
|
(state-set1! (car moves) empty-value)
|
||
|
(clear-move (car moves))
|
||
|
(set! moves (cdr moves)))))))
|
||
|
(take-one)
|
||
|
(if (= (state-ref1 (car moves)) user-value)
|
||
|
(take-one)) ; one more for the user move
|
||
|
(set! game-over #f)
|
||
|
(set! win-line #f)
|
||
|
(draw-board))))
|
||
|
|
||
|
; deciding among same score moves
|
||
|
(define (doexchange?)
|
||
|
(= (random 5) 0))
|
||
|
|
||
|
; find the best move
|
||
|
(define (make-move)
|
||
|
(let ((best-score -1)
|
||
|
(best-move #f))
|
||
|
(for-each-point1
|
||
|
(lambda (point)
|
||
|
(if (= (state-ref1 point) empty-value)
|
||
|
(let ((score (score-if-played point)))
|
||
|
(if (or (> score best-score)
|
||
|
(and (= score best-score) (doexchange?)))
|
||
|
(begin
|
||
|
(set! best-score score)
|
||
|
(set! best-move point)))))))
|
||
|
best-move))
|
||
|
|
||
|
; position evaluation
|
||
|
(define (score-if-played point)
|
||
|
(let ((score 0))
|
||
|
(for-each
|
||
|
(lambda (line)
|
||
|
(let ((user-count 0)
|
||
|
(comp-count 1))
|
||
|
(for-each-point-in-line
|
||
|
(lambda (point)
|
||
|
(let ((val (state-ref1 point)))
|
||
|
(cond
|
||
|
((= val comp-value)
|
||
|
(set! comp-count (1+ comp-count)))
|
||
|
((= val user-value)
|
||
|
(set! user-count (1+ user-count))))))
|
||
|
line)
|
||
|
(cond ((= user-count 0) ; offensive
|
||
|
(begin
|
||
|
(set! score (+ score (vector-ref
|
||
|
#(0 80 100 2000 100000)
|
||
|
comp-count)))
|
||
|
(if (= comp-count 2)
|
||
|
(for-each-point-in-line
|
||
|
(lambda (p)
|
||
|
(if (and (= (state-ref1 p) empty-value)
|
||
|
(not (point-equal? point p)))
|
||
|
(for-each
|
||
|
(lambda (line)
|
||
|
(let ((user-count 0)
|
||
|
(comp-count 0))
|
||
|
(for-each-point-in-line
|
||
|
(lambda (point)
|
||
|
(let ((val (state-ref1 point)))
|
||
|
(cond
|
||
|
((= val comp-value)
|
||
|
(set! comp-count (1+ comp-count)))
|
||
|
((= val user-value)
|
||
|
(set! user-count
|
||
|
(1+ user-count))))))
|
||
|
line)
|
||
|
(if (and (= user-count 0)
|
||
|
(>= comp-count 2))
|
||
|
(set! score (+ score 800)))))
|
||
|
(point-lines p))))
|
||
|
line))))
|
||
|
((= comp-count 1) ; defensive
|
||
|
(set! score (+ score (vector-ref
|
||
|
#(0 50 1500 10000)
|
||
|
user-count)))))))
|
||
|
(point-lines point))
|
||
|
score))
|
||
|
|
||
|
; checking if the game is won
|
||
|
(define (won? move)
|
||
|
(let ((val (state-ref1 move)))
|
||
|
(for-each
|
||
|
(lambda (line)
|
||
|
(if (full-line? line val)
|
||
|
(set! win-line line)))
|
||
|
(point-lines move)))
|
||
|
(set! game-over win-line)
|
||
|
game-over)
|
||
|
|
||
|
; is it a draw?
|
||
|
(define (draw?)
|
||
|
(= (length moves) 64))
|
||
|
|
||
|
;;; point functions
|
||
|
|
||
|
(define (make-point p r c)
|
||
|
(vector p r c))
|
||
|
|
||
|
(define (point-equal? p1 p2)
|
||
|
(and (= (point-plane p1) (point-plane p2))
|
||
|
(= (point-row p1) (point-row p2))
|
||
|
(= (point-column p1) (point-column p2))))
|
||
|
|
||
|
(define (point-plane point)
|
||
|
(vector-ref point 0))
|
||
|
|
||
|
(define (point-row point)
|
||
|
(vector-ref point 1))
|
||
|
|
||
|
(define (point-column point)
|
||
|
(vector-ref point 2))
|
||
|
|
||
|
(define (point->string point)
|
||
|
(string-append
|
||
|
(number->string (point-plane point))
|
||
|
","
|
||
|
(number->string (point-row point))
|
||
|
","
|
||
|
(number->string (point-column point))))
|
||
|
|
||
|
;;; line functions
|
||
|
|
||
|
(define (complement x)
|
||
|
(- 3 x))
|
||
|
|
||
|
; line templates:
|
||
|
; car is the predicate for the line to go through a point.
|
||
|
; cdr is the line.
|
||
|
(define line-tpl
|
||
|
(list
|
||
|
(cons
|
||
|
(lambda (p r c) #t)
|
||
|
(lambda (p r c) (lambda (x) (make-point p r x))))
|
||
|
(cons
|
||
|
(lambda (p r c) #t)
|
||
|
(lambda (p r c) (lambda (x) (make-point p x c))))
|
||
|
(cons
|
||
|
(lambda (p r c) #t)
|
||
|
(lambda (p r c) (lambda (x) (make-point x r c))))
|
||
|
(cons
|
||
|
(lambda (p r c) (= r c))
|
||
|
(lambda (p r c) (lambda (x) (make-point p x x))))
|
||
|
(cons
|
||
|
(lambda (p r c) (= r (complement c)))
|
||
|
(lambda (p r c) (lambda (x) (make-point p x (complement x)))))
|
||
|
(cons
|
||
|
(lambda (p r c) (= p c))
|
||
|
(lambda (p r c) (lambda (x) (make-point x r x))))
|
||
|
(cons
|
||
|
(lambda (p r c) (= p (complement c)))
|
||
|
(lambda (p r c) (lambda (x) (make-point x r (complement x)))))
|
||
|
(cons
|
||
|
(lambda (p r c) (= p r))
|
||
|
(lambda (p r c) (lambda (x) (make-point x x c))))
|
||
|
(cons
|
||
|
(lambda (p r c) (= p (complement r)))
|
||
|
(lambda (p r c) (lambda (x) (make-point x (complement x) c))))
|
||
|
(cons
|
||
|
(lambda (p r c) (= p r c))
|
||
|
(lambda (p r c) (lambda (x) (make-point x x x))))
|
||
|
(cons
|
||
|
(lambda (p r c) (= p r (complement c)))
|
||
|
(lambda (p r c) (lambda (x) (make-point x x (complement x)))))
|
||
|
(cons
|
||
|
(lambda (p r c) (= p (complement r) c))
|
||
|
(lambda (p r c) (lambda (x) (make-point x (complement x) x))))
|
||
|
(cons
|
||
|
(lambda (p r c) (= (complement p) r c))
|
||
|
(lambda (p r c) (lambda (x) (make-point (complement x) x x))))))
|
||
|
|
||
|
; list of lines going through a point
|
||
|
(define (point-lines point)
|
||
|
(let ((plane (point-plane point))
|
||
|
(row (point-row point))
|
||
|
(column (point-column point))
|
||
|
(lines '()))
|
||
|
(for-each
|
||
|
(lambda (tpl)
|
||
|
(if ((car tpl) plane row column)
|
||
|
(set! lines
|
||
|
(cons
|
||
|
((cdr tpl) plane row column)
|
||
|
lines))))
|
||
|
line-tpl)
|
||
|
lines))
|
||
|
|
||
|
; whther line crosses point
|
||
|
(define (crosses? line point)
|
||
|
(if line
|
||
|
(let ((crosses?
|
||
|
(lambda (return)
|
||
|
(for-each-point-in-line
|
||
|
(lambda (line-point)
|
||
|
(if (point-equal? line-point point)
|
||
|
(return #t)))
|
||
|
line)
|
||
|
(return #f))))
|
||
|
(call/cc crosses?))
|
||
|
#f))
|
||
|
|
||
|
;;; iterators
|
||
|
|
||
|
(define (for-each-4 func)
|
||
|
(for-each func '(0 1 2 3)))
|
||
|
|
||
|
(define (for-each-5 func)
|
||
|
(for-each func '(0 1 2 3 4)))
|
||
|
|
||
|
; each point on the board (func plane row col)
|
||
|
(define (for-each-point func)
|
||
|
(for-each-4
|
||
|
(lambda (plane)
|
||
|
(for-each-4
|
||
|
(lambda (row)
|
||
|
(for-each-4
|
||
|
(lambda (col)
|
||
|
(func plane row col))))))))
|
||
|
|
||
|
; similar to the above (func point)
|
||
|
(define (for-each-point1 func)
|
||
|
(for-each-point
|
||
|
(lambda (plane row col)
|
||
|
(func (make-point plane row col)))))
|
||
|
|
||
|
; for each point in a line call (func point)
|
||
|
(define (for-each-point-in-line func line)
|
||
|
(for-each-4
|
||
|
(lambda (x)
|
||
|
(func (line x)))))
|
||
|
|
||
|
; is the line full of value
|
||
|
(define (full-line? line value)
|
||
|
(let ((full?
|
||
|
(lambda (return)
|
||
|
(for-each-point-in-line
|
||
|
(lambda (point)
|
||
|
(if (not (= (state-ref1 point) value))
|
||
|
(return #f)))
|
||
|
line)
|
||
|
(return #t))))
|
||
|
(call/cc full?)))
|
||
|
|
||
|
;;; game initiation
|
||
|
|
||
|
(tune-reset)
|
||
|
(new-game)
|