Create a gist now

Instantly share code, notes, and snippets.

@hoehrmann /4wins.scm
Last active Dec 18, 2015

An implementation of Captain's mistress in Scheme written around 2003 as part of an assignment.
; +-------------------------------------------------------------------------+
; Bjoern Hoehrmann -- <bjoern@hoehrmann.de> -- <http://bjoern.hoehrmann.de>
; +-------------------------------------------------------------------------+
(define HEIGHT 6)
(define WIDTH 7)
(define X-WINS 4)
(define empty-char "-")
(define x-char "x")
(define o-char "o")
; creates a list with n elements using the function func to create each
; element. Function func takes one parameter indicating the number of
; elements still to be created including the current element.
(define (create-list n func)
(if (<= n 0) ()
(cons (func n) (create-list (- n 1) func))))
; tests whether x,y is a position out of the boundaries of matrix l
(define (out-of-bounds? l x y)
(or
(< x 0) ; negative index
(< y 0) ; negative index
(>= y (length l)) ; less rows
(>= x (length (list-ref l y))))) ; less columns in row
; tests whether the first row in the matrix l contains elements equal
; to empty-char, i.e., there is still space left and the game may
; continue...
(define (space-left? l)
(if (null? l) #f
(if (string=? (car l) empty-char) #t
(space-left? (cdr l)))))
; returns the value of the field at x,y of the matrix l or #<void>
; if x,y denotes a field outside the boundaries of the matrix
(define (list-ref-xy l x y)
(if (not (out-of-bounds? l x y))
(list-ref (list-ref l y) x)))
; c-s counts the number of adjacent siblings in the matrix in the given
; direction with the same value as the source field. Each field in the
; matrix has up to eight adjacent siblings, i.e.
;
; 1 2 3 -1 -1 -1 -1 0 1
; 4 x 6 0 0 0 -1 0 1
; 7 8 9 1 1 1 -1 0 1
;
; direction trans. to find new y trans. to find new x
; y+(((direction-1)/3)%3)-1 x+((direction-1)%3)-1
;
; c-s takes the matrix as l, the coordinates of the source field as x
; and y and the direction. The direction is an integer as in the figure
; above. The coordinates of the sibling are determined by applying the
; formulas above. Think of direction as an angle (direction-1)*45░.
;
; If the source field and the next adjacent sibling in the matrix have
; the same string value, c-s will take the sibling as new source field
; and increments the sibling count accordingly. It will stop if it
; reaches the matrix boundaries. It will return 0 if no siblings are
; found.
(define (c-s l x y direction)
(let ((new-y (+ y (- (modulo (floor (/ (- direction 1) 3)) 3) 1)))
(new-x (+ x (- (modulo (- direction 1) 3) 1))))
(if (and (not (out-of-bounds? l new-x new-y))
(string=? (list-ref-xy l x y) (list-ref-xy l new-x new-y)))
(+ 1 (c-s l new-x new-y direction))
0)))
; won? determines whether the field located at x,y in the matrix l is
; part of a winning condition w. A winning condition is an integer
; representing the number of fields in a row (horizontal, vertical or
; diagonal) that need to be filled by the same value. It uses c-s
; to count the adjacent siblings in one direction, adds the number
; of adjacent siblings in the opposite direction and compares the
; result with w.
(define (won? l x y w)
(or
(>= (+ (c-s l x y 1) (c-s l x y 9)) w) ; upper-left to lower-right
(>= (+ (c-s l x y 2) (c-s l x y 8)) w) ; top to bottom
(>= (+ (c-s l x y 3) (c-s l x y 7)) w) ; upper-right to lower-left
(>= (+ (c-s l x y 4) (c-s l x y 6)) w) ; left to right
))
; first k elements of l or a copy of l if l has less than k elements
(define (list-head l k)
(if (and (> k 0) (not (null? l)))
(cons (car l) (list-head (cdr l) (- k 1)))
()))
; returns the number of the last row in the matrix l where column c is
; set to the empty-char or 0 if no such row exists; note that you have
; to substract 1 from the return value to get the zero-based index of
; the row in the matrix.
(define (find-row l c)
(if (or (null? l) (not (string=? (list-ref (car l) c) empty-char))) 0
(+ 1 (find-row (cdr l) c))))
; returns a modified copy of the list l where the i-th element is v
(define (set-element-at l i value)
(append (list-head l i) (list value) (list-tail l (+ i 1))))
; returns a modified copy of the matrix l where the field at x,y is v
(define (set-element-at-xy l x y value)
(set-element-at l y (set-element-at (list-ref l y) x value)))
; converts the list of strings l to a single string by inserting the
; string s between all elements in l. E.g. (join "+" (list 1 2 3))
; would return the string "1+2+3".
(define (join s l)
(if (null? l) ""
(if (null? (cdr l)) (car l)
(string-append (car l) s (join s (cdr l))))))
; displays the matrix l on screen
(define (display-matrix l)
(display "(")
(display (join " " (car l)))
(display ")\n")
(if (not (null? (cdr l)))
(display-matrix (cdr l)))
)
; displays the matrix l and column labels on screen
(define (display-field l)
(display-matrix l)
(display " ")
(display (join " " (create-list WIDTH (lambda(x)
(number->string
(+ (- WIDTH x) 1))))))
(display "\n")
)
; the game, takes a matrix l, a player p and a string s that is displayed
; before all other output; reads and validates user input, modifies the
; matrix accordingly and stops if the user wants to quit, won the game
; or all columns are filled.
(define (game l p s)
(display s)
(display-field l)
(display "Player ")
(display p)
(display ", enter column number or q to quit: ")
(let* ((input (read-line))
(col (string->number input))
(valid (and (integer? col)
(exact? col)
(not (out-of-bounds? l (- col 1) 0))))
(row (if valid (find-row l (- col 1)) 0)))
(cond
((string=? input "q")
(display "Good bye!\n"))
((not valid)
(game l p "Invalid input, try again:\n"))
((zero? row)
(game l p "No space left in column, try again:\n"))
(else
(let* ((newl (set-element-at-xy l (- col 1) (- row 1) p)))
(cond
((won? newl (- col 1) (- row 1) (- X-WINS 1))
(display-field newl)
(display (string-append "Congratulations, " p " won the game!\n")))
((not (space-left? (car newl)))
(display-field newl)
(display "Remis!\n"))
(else
(game newl (if (string=? p x-char) o-char x-char) ""))))))))
(define (start)
(let ((f (create-list HEIGHT (lambda(i) (create-list
WIDTH (lambda(j) empty-char))))))
(game f x-char "Welcome!\n")))
; (start)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment