666 lines
18 KiB
Executable File

:; exec /usr/local/bin/stk -f "$0" "$@"
;;; 3D Tic-Tac-Toe
;;; written by Edin "Dino" Hodzic
;;; 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)
(define grid-color 'black)
(define sign-color 'black)
(define win-sign-color 'black)
(define last-move-sign-color 'black)
(define show-line-color 'black))
(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)
(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)
(.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)))
(row (inexact->exact (floor rowq)))
(col (inexact->exact (floor
(/ (- canx (+ x0 (* delx rowq)))
(if (and (<= 0 plane 3) (<= 0 row 3) (<= 0 col 3))
(make-point plane row col)
; 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))))
(set! shown-lines-point point)
(.board 'delete "lines")
(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)))
(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))
(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))
(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
"3D Tic-Tac-Toe\n\
Edin \"Dino\" Hodzic\n\")
(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 '
:label "Cell Width"
:variable 'cell-width
:command (lambda (v) (set-angle! angle) (draw-board))
:relief 'sunken
:orient 'horizontal)
(scale '
:label "Cell Height"
:variable 'cell-height
:command (lambda (v) (set-angle! angle) (draw-board))
:relief 'sunken
:orient 'horizontal)
(scale '
: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 ' :fill 'x :side 'top)
(pack ' :fill 'x :side 'top)
(pack ' :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))
(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)
(set! game-over #f)
(set! win-line #f)
(set! moves '())
;;; 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)
(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
(state-set1! move val)
(set! moves (cons move moves))
(if (and
(not (null? (cdr moves)))
(not (null? (cddr moves))))
(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))
(state-set1! (car moves) empty-value)
(clear-move (car moves))
(set! moves (cdr moves)))))))
(if (= (state-ref1 (car moves)) user-value)
(take-one)) ; one more for the user move
(set! game-over #f)
(set! win-line #f)
; deciding among same score moves
(define (doexchange?)
(= (random 5) 0))
; find the best move
(define (make-move)
(let ((best-score -1)
(best-move #f))
(lambda (point)
(if (= (state-ref1 point) empty-value)
(let ((score (score-if-played point)))
(if (or (> score best-score)
(and (= score best-score) (doexchange?)))
(set! best-score score)
(set! best-move point)))))))
; position evaluation
(define (score-if-played point)
(let ((score 0))
(lambda (line)
(let ((user-count 0)
(comp-count 1))
(lambda (point)
(let ((val (state-ref1 point)))
((= val comp-value)
(set! comp-count (1+ comp-count)))
((= val user-value)
(set! user-count (1+ user-count))))))
(cond ((= user-count 0) ; offensive
(set! score (+ score (vector-ref
#(0 80 100 2000 100000)
(if (= comp-count 2)
(lambda (p)
(if (and (= (state-ref1 p) empty-value)
(not (point-equal? point p)))
(lambda (line)
(let ((user-count 0)
(comp-count 0))
(lambda (point)
(let ((val (state-ref1 point)))
((= val comp-value)
(set! comp-count (1+ comp-count)))
((= val user-value)
(set! user-count
(1+ user-count))))))
(if (and (= user-count 0)
(>= comp-count 2))
(set! score (+ score 800)))))
(point-lines p))))
((= comp-count 1) ; defensive
(set! score (+ score (vector-ref
#(0 50 1500 10000)
(point-lines point))
; checking if the game is won
(define (won? move)
(let ((val (state-ref1 move)))
(lambda (line)
(if (full-line? line val)
(set! win-line line)))
(point-lines move)))
(set! game-over win-line)
; 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)
(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
(lambda (p r c) #t)
(lambda (p r c) (lambda (x) (make-point p r x))))
(lambda (p r c) #t)
(lambda (p r c) (lambda (x) (make-point p x c))))
(lambda (p r c) #t)
(lambda (p r c) (lambda (x) (make-point x r c))))
(lambda (p r c) (= r c))
(lambda (p r c) (lambda (x) (make-point p x x))))
(lambda (p r c) (= r (complement c)))
(lambda (p r c) (lambda (x) (make-point p x (complement x)))))
(lambda (p r c) (= p c))
(lambda (p r c) (lambda (x) (make-point x r x))))
(lambda (p r c) (= p (complement c)))
(lambda (p r c) (lambda (x) (make-point x r (complement x)))))
(lambda (p r c) (= p r))
(lambda (p r c) (lambda (x) (make-point x x c))))
(lambda (p r c) (= p (complement r)))
(lambda (p r c) (lambda (x) (make-point x (complement x) c))))
(lambda (p r c) (= p r c))
(lambda (p r c) (lambda (x) (make-point x x x))))
(lambda (p r c) (= p r (complement c)))
(lambda (p r c) (lambda (x) (make-point x x (complement x)))))
(lambda (p r c) (= p (complement r) c))
(lambda (p r c) (lambda (x) (make-point x (complement x) x))))
(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 '()))
(lambda (tpl)
(if ((car tpl) plane row column)
(set! lines
((cdr tpl) plane row column)
; whther line crosses point
(define (crosses? line point)
(if line
(let ((crosses?
(lambda (return)
(lambda (line-point)
(if (point-equal? line-point point)
(return #t)))
(return #f))))
(call/cc crosses?))
;;; 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)
(lambda (plane)
(lambda (row)
(lambda (col)
(func plane row col))))))))
; similar to the above (func point)
(define (for-each-point1 func)
(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)
(lambda (x)
(func (line x)))))
; is the line full of value
(define (full-line? line value)
(let ((full?
(lambda (return)
(lambda (point)
(if (not (= (state-ref1 point) value))
(return #f)))
(return #t))))
(call/cc full?)))
;;; game initiation