An implementation of Captain's mistress in Scheme written around 2003 as part of an assignment.

4wins.scm

; +-------------------------------------------------------------------------+
;  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)