;                                                Andrea Pound,  ID#477821
;                                                FINAL PROJECT,  12/19/01
;                                                Lab W3
;
;  connect5.ss v.2.0

;  Set the length of consecutive pieces needed to win:
(define WIN-LENGTH 5)

;  Define what my pieces will be called:
(define BLACK 'X)

;  Define the what the opponent's pieces will be called:
(define WHITE 'O)

;  Define an empty space on the board
(define BLANK '-)

;  Define some special priorities for the priority board
;  so they'll be easy to sort.  Not only does the current
;  scoring heuristic treat these as special values, to be
;  modified only if a more important special case arises,
;  but for boards that are 20x20 or less, there's
;  no way the current scoring heuristic could generate
;  a priority larger than these values or cause these
;  values to be added to the point where they interfere
;  with a higher special priority.
;
;  WIN is for automatic wins (must come first)
(define WIN 1234567890)
;  FORCED is for forced blocks (opponent is about to win)
(define FORCED 1234567)
;  GREAT is for when there's an inevitable win (double threat)
(define GREAT 1234)


;  make-matrix:  number number -> vector-of-vector
;  ... takes in a number of columns and a number of rows and returns a 
;  matrix filled with the initial value 0. 

(define (make-matrix cols rows)
  (build-vector rows (lambda (x) (make-vector cols 0))))

;(define my-matrix (make-matrix 5 5))
;(define test1 (make-matrix 1 5))
;(define test2 (make-matrix 5 1))
;(define test3 (make-matrix 0 5))
;(define test4 (make-matrix 1 0))
;(define zero-matrix (make-matrix 0 0))


;  matrix-rows:  matrix -> number
;  ... takes in a matrix and returns the number of rows it has.
;  (these generic functions do not crash on 0 x 5 or 5 x 0
;  matrices in part because make-matrix won't create such things
;  and in part because 

(define (matrix-rows a-matrix)
  (vector-length a-matrix))

;(matrix-rows my-matrix)
;(matrix-rows test1)
;(matrix-rows zero-matrix)


;  matrix-cols:  matrix -> number
;  ... takes in a matrix and returns how many columns it has
;  (or 0 if the matrix has no rows, because it seems like a
;  matrix with 0 rows would have 0 columns too)

(define (matrix-cols a-matrix)
  (if (>= 0 (matrix-rows a-matrix)) 0
    (vector-length (vector-ref a-matrix 0))))

;(matrix-rows my-matrix)
;(matrix-rows test2)
;(matrix-cols zero-matrix)


;  matrix-ref:  number number matrix-> alpha or void
;  ... takes in a column value and a row value and returns whatever is at that
;  coordinate in the matrix (or void if the matrix has 0 rows or columns)

(define (matrix-ref cols rows a-matrix)
  (if (or (>= 0 (matrix-rows a-matrix)) (>= 0 (matrix-cols a-matrix))) (void)
   (vector-ref (vector-ref a-matrix rows) cols)))

;(matrix-ref 0 4 my-matrix)
;(matrix-ref 0 1 test1)
;(matrix-ref 0 0 test2)
;(matrix-ref 0 0 zero-matrix)


;  matrix-set!:  number number vector-of-vector alpha -> void
;  ... takes in a column numeric value and a row numeric value and,
;  as a side-effect, sets the value of that location in the matrix to be 
;  the item provided.
;  It'll just return void if trying to set a matrix that is partly
;  zero dimensional.

(define (matrix-set! cols rows a-matrix new-val)
  (if (and (< 0 (matrix-rows a-matrix)) (< 0 (matrix-cols a-matrix)))
    (vector-set! (vector-ref a-matrix rows) cols new-val) (void)))

;(vector-ref my-matrix 2)
;(matrix-set! 2 0 my-matrix 8)
;(vector-ref my-matrix 2)
;(matrix-set! 2 4 my-matrix 'hi)
;(matrix-set! 0 0 my-matrix 'yo)
;(matrix-set! 4 2 my-matrix 9)
;(matrix-set! 0 0 zero-matrix 'dontbarf)


;  Make a structure to represent a coordinate in the matrix:
(define-struct mposn (cols rows))
;  ... where cols is the column index and rows is the row index, both of which
;  are numbers.


;  mvalue:  mposn matrix -> alpha
;  ... a function to get the value stored at mposn in a matrix
(define (mvalue mposn a-matrix)
  (matrix-ref (mposn-cols mposn) (mposn-rows mposn) a-matrix))


;  mposn->list:  mposn -> list
;  ... function to convert an mposn into a tiny list for printing
(define (mposn->list mposn)
  (list (mposn-cols mposn) (mposn-rows mposn)))


;  sloop=:  number number (number -> mposn or list-of-mposn) -> 
;  list-of-mposn or list-of-list-of-mposn
;  ... generic single-variable loop for returning batches of mposns
;  (lists or list of list)

(define (sloop= start stop body!)
  (if (= start stop) empty
      (cons (body! start) (sloop= (add1 start) stop body!))))

;  dloop=:  number number (number -> number) (number -> number)
;           number number (number number -> list-of-mposn) -> 
;           list-of-list-of-mposn
;  ... generic double-variable loop for returning a
;  list-of-list-of-mposns in a matrix

(define (dloop= start1 start2 inc1 inc2 stop1 stop2 body!)
  (if (or (= start1 stop1) (= start2 stop2)) empty
      (cons (body! start1 start2)
      (dloop= (inc1 start1) (inc2 start2) inc1 inc2 stop1 stop2 body!))))


;  matrix-slices:  number number number -> list-of-list
;  ... takes in number rows, number columns and a size and returns all 
;  "slices" of size in length.  Slices are lists of positions in a
;  hypothetical matrix.  They are sifted out of all lines in the matrix:
;  all the horizontals, verticals, and diagonals.  They are not simply
;  lines in the matrix.  They are all the lines of a certain size in
;  the matrix.  A list of slices of size WIN-LENGTH will define the
;  search space for wins and forced blocks.

(define (matrix-slices cols rows size)
  (if (or (< cols 1) (< rows 1) (< size 1))
      (printf "Number of columns and number of rows and size of slice must all be greater than 0.~n")
      (cut-slices size (append 
          (get-rows rows cols)
          (get-cols rows cols)
          (get-down-diags rows cols)
          (get-up-diags rows cols)))))


;  get-rows:  number number -> list-of-list-of-mposn
;  ... takes in numbers of columns and rows in a hypothetical matrix;
;  returns a list of all rows (i.e. a list of list of mposns that
;  would exist as rows in the matrix)

(define (get-rows cols rows)
  (append (sloop= 0 rows (lambda (r) (sloop= 0 cols (lambda (c) (make-mposn c r)))))))

;(get-rows 5 5)
;(get-rows 10 10)


;  get-columns:  number number -> list-of-list-of-mposn
;  ... takes in numbers of columns and rows in a hypothetical matrix;
;  returns a list of all columns (i.e. a list of list of mposns that
;  would exist as columns in the matrix)

(define (get-cols cols rows)
  (append (sloop= 0 cols (lambda (c) (sloop= 0 rows (lambda (r) (make-mposn c r)))))))

;(get-cols 5 5)
;(get-cols 10 10)


;  get-down-diags:  number number -> list-of-list-of-mposn
;  ... takes in numbers of columns and rows in a hypothetical matrix;
;  returns a list of all diagonals with negative slopes
;  (i.e. a list of list of mposns that would exist as downward
;  sloping lines in the matrix)

(define (get-down-diags cols rows)
  (append (sloop= 0 rows (lambda (r) (dloop= 0 r (lambda (i) (add1 i)) (lambda (i) (add1 i)) cols rows (lambda (c r) (make-mposn c r)))))
          (sloop= 1 cols (lambda (c) (dloop= c 0 (lambda (i) (add1 i)) (lambda (i) (add1 i)) cols rows (lambda (c r) (make-mposn c r)))))))

;(get-down-diags 5 5)
;(get-down-diags 6 6)


;  get-up-diags:  number number -> list-of-list-of-mposn
;  ... takes in numbers of columns and rows in a hypothetical matrix;
;  returns a list of all diagonals with positive slopes
;  (i.e. a list of list of mposns that would exist as upward
;  sloping lines in the matrix)

(define (get-up-diags cols rows)
  (append (sloop= 0 rows (lambda (r) (dloop= 0 r (lambda (i) (add1 i)) (lambda (i) (sub1 i)) cols -1 (lambda (c r) (make-mposn c r)))))
          (sloop= 1 cols (lambda (c) (dloop= c (sub1 rows) (lambda (i) (add1 i)) (lambda (i) (sub1 i)) cols 0 (lambda (c r) (make-mposn c r)))))))

;(get-up-diags 5 5)
;(get-up-diags 6 6)


;  cut-slices:  number list-of-list-of-mposn -> list-of-list-of-mposn
;  ... takes in the size to cut the slices and the list of all lines
;  in a matrix (that is, the lists of mposn that compose the
;  horizontals, verticals, and diagonals); returns a list of all slices
;  in the matrix.

(define (cut-slices size list-of-lines)
  (if (empty? list-of-lines) empty
      (if (> size (length (first list-of-lines)))
          (cut-slices size (rest list-of-lines))
          (append (slice-line size (first list-of-lines))
                  (cut-slices size (rest list-of-lines))))))


;  slice-line:  number list-of-mposn -> list-of-list-of-mposn
;  ... takes in the size of desired slices and a line of a
;  matrix; returns all the slices of that size existing in that line

(define (slice-line size line)
  (if (empty? line) empty
      (if (> size (length line)) empty
          (cons (one-slice size line 0) (slice-line size (rest line))))))


;  one-slice:  number list-of-mposn number -> list-of-mposn
;  ... takes in the size of the desired slice, the line, and
;  a counter; returns the first slice that is size in length

(define (one-slice size line counter)
  (if (>= counter size) empty
      (cons (first line) (one-slice size (rest line) (add1 counter)))))

;(cut-slices 5 (get-rows 6 6))
;(define five-space (matrix-slices 19 19 5))
;(define six-space (matrix-slices 19 19 6))
;(matrix-slices 6 6 5)
;(matrix-slices 1 1 0)
;(matrix-slices 5 5 1)


;  mlist:  matrix -> list-of-mposn
;  ... returns a flat list of all the mposns in the matrix

(define (mlist matrix)
  (local [(define (aloop= start stop body!)
            (if (= start stop) empty
              (append (body! start) (aloop= (add1 start) stop body!))))]
  (aloop= 0 (matrix-rows matrix) (lambda (r) 
     (sloop= 0 (matrix-cols matrix) (lambda (c) (make-mposn c r)))))))

;(mlist (make-matrix 5 5))


;  matrix-print:  matrix -> void
;  ... takes in a matrix and prints it out as a side-effect
;  (not actually used in final program, but useful in testing and 
;  makes sense as a matrix tool)

(define (matrix-print matrix)
  (local [(define myrows (get-rows (matrix-cols matrix) (matrix-rows matrix)))
          (define (printrow a-row)
            (if (empty? a-row) (printf "~n")
                (begin
                  (printf "~s " (mvalue (first a-row) matrix)) 
                  (printrow (rest a-row)))))
          (define (printrowlist rowlist)
            (if (empty? rowlist) (void)
                (begin
                  (printrow (first rowlist))
                  (printrowlist (rest rowlist)))))]
    (printrowlist myrows)))

;(matrix-print (make-matrix 10 10))


; test-board is a little board used repeatedly in initial testing;
; it no longer shows a true game, but it has before (many times), and
; invalid games are nevertheless useful for examining the behavior
; of the program, which should still discover incipient wins,
; even if there are completed wins on the board or too many O's vs. X's
; ... see also the separate file tests.txt

(define test-board 
  (list (list '- '- '- '- '- 'X)
        (list '- 'X 'X 'X '- '-)
        (list '- 'O 'O '- 'O '-)
        (list '- '- 'O '- '- 'O)
        (list '- 'O '- '- '- '-)
        (list 'O '- '- '- '- 'X)))

; big-board is a huge board that was used over and over again,
; just like test-board, to set up situations where the program
; would have to respond in a desirable way; it no longer shows
; a true game with equal numbers of X's and O's
; ... see also the separate file tests.txt

(define big-board (list 
 (list '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '-)
 (list '- '- '- '- 'O '- 'O 'X '- '- '- '- '- '- '- 'O '- '- '-)
 (list '- '- '- '- '- '- '- '- '- 'X '- '- 'O 'X 'O 'X '- '- '-)
 (list '- '- '- 'O 'X 'O 'X 'O 'O 'O 'X 'X 'O 'X 'X 'X 'O '- '-)
 (list '- '- 'X 'X 'X 'O 'X 'O 'X 'O 'O 'O 'X 'O 'O 'X '- '- '-)
 (list '- '- 'O 'O 'X 'X 'O 'X 'X 'O 'X 'O 'O 'O 'X 'X 'O '- '-)
 (list '- '- '- 'X 'O 'O '- 'X 'O 'O '- 'X 'X '- 'O 'O '- '- '-)
 (list 'O 'X 'X 'X 'X 'O 'O 'X 'X 'X 'X 'O '- 'X '- '- '- '- '-)
 (list '- 'O 'X 'O 'O 'X 'X 'X 'O 'X 'O '- 'O 'O 'X '- '- '- '-)
 (list 'X '- 'O 'O 'X 'O 'O 'O 'O 'X 'X 'O '- 'X '- 'O '- '- '-)
 (list '- '- 'X '- 'O '- 'X '- '- 'O 'X 'O 'X '- '- '- '- '- '-)
 (list '- 'O 'O 'X 'X 'X 'X 'O 'O 'X 'X '- 'O '- '- '- '- '- '-)
 (list '- '- 'X 'O 'O 'X 'X 'X 'X 'O 'O 'X 'O 'O '- '- '- '- '-)
 (list '- '- '- 'X 'O 'O 'O 'X 'O 'O 'X '- 'O 'X 'O '- '- '- '-)
 (list '- '- 'O 'X 'X 'X 'O 'X '- 'X 'X 'O 'O '- '- 'X '- '- '-)
 (list '- '- '- '- 'O '- 'X 'X '- 'O '- '- 'X '- '- '- '- '- '-)
 (list '- '- '- '- 'X 'O 'O 'O '- '- '- '- '- '- '- '- '- '- '-)
 (list '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '-)
 (list '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '-)))


;  initialize-board:   -> matrix
;  ... reads in a list containing lists which represent matrix rows and
;  returns a game board containing those values in the appropriate places.

(define (initialize-board)
  (local [(define boardlist (read))
          ; tests available for quick commenting/uncommenting
          ;(define boardlist test-board)
          ;(define boardlist big-board)
          (define r (length boardlist))
          (define c (length (first boardlist)))
          (define board (make-matrix c r))
          (define (list->row list row-index col-index)
            (if (empty? list) (void)
              (begin (matrix-set! col-index row-index board (first list))
                (list->row (rest list) row-index (add1 col-index)))))
          (define (lol->board lol row-index)
            (if (empty? lol) (void)
              (begin (list->row (first lol) row-index 0)
                (lol->board (rest lol) (add1 row-index)))))]
      (begin (lol->board boardlist 0) board)))

;(matrix-print (initialize-board))


;  play-a-game:   -> void
;  ... calls other functions to set up a game board and a priority board,
;  place priorities on the priority board, sort the board positions by
;  priority, and print out the position that was first on the priority list.
;  Note that the space of slices having WIN-LENGTH and the space of
;  slices having WIN-LENGTH+1 are generated only here on the assumption
;  (which may be incorrect) that passing copies of the lists of slices
;  would be faster than generating them many times.  That might be
;  important if this program were made to search additional boards
;  in a minimax algorithm.

(define (play-a-game)
  (local [(define board (initialize-board))
          (define cols (matrix-cols board))
          (define rows (matrix-rows board))
          (define space (matrix-slices cols rows WIN-LENGTH))
          (define spaceplus (matrix-slices cols rows (add1 WIN-LENGTH)))
          (define priorities (threat-search space board (prioritize board)))
          (define doublethreats (extra-search spaceplus board priorities))]
  (print (mposn->list (first (order-threats doublethreats))))))
  ; test available for quick commenting/uncommenting
  ;(begin (matrix-print board) (printf "~n") (matrix-print priorities)
  ;  (printf "~n~s" (mposn->list (first (order-threats priorities)))))))


;  prioritize:  matrix -> matrix
;  ... generates a priority board of the same size as the gameboard.
;  All positions on the priority board are set to 0 if the corresponding
;  position on the gameboard is filled; otherwise, they're set to small
;  positive values that will weight the priorities in favor of the center.
;  Actually, the initial weights skew slightly down and to the right of center,
;  except for the very center of any odd-width board or the upper-left
;  center of an even-width board, which are more highly valued.

(define (prioritize board)
  (local [(define (fori= start stop body!)
            (if (= (add1 start) stop) (body! start)
                (begin (body! start) (fori= (add1 start) stop body!))))
          (define rows (matrix-rows board))
          (define cols (matrix-cols board))
          (define priority-board (make-matrix cols rows))
          (define flip (floor (/ rows 2)))
          (define minweight (/ 1 5))
          (define magicnum 20)
          (define (weight c r)
            (cond [(and (= c flip) (= r flip)) 1]
               [(and (< c flip) (< r flip)) 
                (+ minweight (/ (+ c r) magicnum))]
               [(and (< c flip) (>= r flip)) 
                (+ minweight (/ (+ c (- rows r)) magicnum))]
               [(and (>= c flip) (< r flip)) 
                (+ minweight (/ (+ (- cols c) r) magicnum))]
               [else (+ minweight (/ (+ (- cols c) (- rows r)) magicnum))]))]
  (begin (fori= 0 rows (lambda (r) (fori= 0 cols (lambda (c) 
           (and (eq? (matrix-ref c r board) BLANK) 
             (matrix-set! c r priority-board (weight c r)))))))
         priority-board)))


;  threat-search:  list-of-list matrix matrix -> matrix
;  ... takes in a list of slices, each of slice WIN-LENGTH,
;  for processing its next inputs, the gameboard and the 
;  priority board.  Returns a new version of the priority
;  board.  As it considers each slice, it determines the
;  appropriate priority to be added on the priority board 
;  to every member of the slice that is empty on the gameboard.  
;  If a WIN is found, the priority of the empty space is set 
;  to WIN.  If a FORCED block is found, the priority of the empty 
;  space is set to FORCED and only increased if a WIN is found 
;  there in an intersecting slice.  If there's no WIN or FORCED
;  block for a slice and the slice is winnable (contains pieces 
;  of exactly one color), the priority of all playable spaces in 
;  the slice is set to their current priority plus the square of 
;  the number of pieces in the slice (except for spaces that 
;  have already received WIN or FORCED priority).  Slices 
;  eventually winnable by black receive a tiny bonus
;  to make the program slightly more aggressive. 

(define (threat-search slices board priority-board)
  (local [(define blackbonus 0.25)
          (define (actual-value mposn value)
            (cond [(= 0 (mvalue mposn priority-board)) 0]
                  [(= value (sub1 WIN-LENGTH)) WIN]
                  [(= value (- 0 (sub1 WIN-LENGTH))) FORCED]
                  [else (+ (mvalue mposn priority-board) 
                           (if (> 0 value) 
                               (square value) 
                               (+ blackbonus (square value))))]))
          (define (best-value v1 v2)
            (cond [(or (>= v1 WIN) (>= v2 WIN)) WIN]
                  [(or (>= v1 FORCED) (>= v2 FORCED)) FORCED]
                  [(> v1 v2) v1]
                  [else v2]))
          (define (addvalue slice value)
            (if (empty? slice) (void)
                (begin (matrix-set! (mposn-cols (first slice))
                       (mposn-rows (first slice)) priority-board
                       (best-value (mvalue (first slice) priority-board)
                                   (actual-value (first slice) value)))
                       (addvalue (rest slice) value))))]
  (if (empty? slices) priority-board
      (begin (addvalue (first slices) (count-pieces (first slices) board 0 0))
      (threat-search (rest slices) board priority-board)))))


;  count-pieces:  list-of-mposn matrix number number -> number
;  ... takes in a slice of a gameboard, a gameboard, the
;  number of black pieces found in the slice so far, and the number of white
;  pieces found in the slice so far.  For slices containing only pieces
;  of one color, it returns the number of black pieces as a positive
;  value or the number of white pieces as a negative value.  If the
;  slice contains no pieces or isn't a winnable slice (contains both
;  black and white pieces), it returns 0.

(define (count-pieces slice board blacks whites)
  (if (empty? slice)
      (cond [(= 0 whites) blacks]
            [(= 0 blacks) (- 0 whites)]
            [else 0])
      (cond [(eq? BLACK (mvalue (first slice) board)) 
             (count-pieces (rest slice) board (add1 blacks) whites)]
            [(eq? WHITE (mvalue (first slice) board))
             (count-pieces (rest slice) board blacks (add1 whites))]
            [else (count-pieces (rest slice) board blacks whites)])))


;  extra-search:  list-of-list matrix matrix -> matrix
;  ... takes in a list of slices to search in the next
;  inputs, the gameboard and the priority board.  
;  Returns a new version of the priority board.  Each
;  slice should be of size WIN-LENGTH + 1.  The search
;  locates slices that have blanks on the end and
;  WIN-LENGTH - 2 black pieces in the middle, leaving
;  one blank open in the middle.  Slices like that are
;  guaranteed wins on black's next move, if black is able
;  to fill in the middle blank on this turn, so the
;  priority of the middle blank is set to GREAT.

(define (extra-search slices board priority-board)
  (local [(define (checkslice slice)
            (if (not (= (- WIN-LENGTH 2) 
                        (count-pieces (first slices) board 0 0))) (void)
              (if (not (and (eq? BLANK (mvalue (first slice) board))
                    (eq? BLANK (mvalue (first (reverse slice)) board))))
                  (void)
                  (greatblank (rest slice)))))
          (define (greatblank slice)
            (if (empty? slice) (void)
              (if (eq? BLANK (mvalue (first slice) board))
                (matrix-set! (mposn-cols (first slice))
                             (mposn-rows (first slice))
                             priority-board GREAT)
                    (greatblank (rest slice)))))]
    (if (empty? slices) priority-board
        (begin (checkslice (first slices)) 
               (extra-search (rest slices) board priority-board)))))


;  order-threats:  matrix -> list-of-mposn
;  ... takes in a matrix of numbers and returns them as a list
;  of mposns sorted in descending order by their values in the matrix

(define (order-threats priority-board)
  (local [(define priorityspace (mlist priority-board))
          (define (higher-priority? mposn1 mposn2)
            (local [(define v1 (mvalue mposn1 priority-board))
                    (define v2 (mvalue mposn2 priority-board))]
              (> v1 v2)))]
    (quicksort priorityspace higher-priority?)))


(play-a-game)