#lang slideshow
(require racket/class
         racket/set
         racket/promise
         compatibility/mlist
         (only-in racket/list shuffle argmax))

(define field-size 4)

;(define all-colors (list "red" "yellow" "green" "black" "blue" "orange" "teal"))
(define all-colors '("red" "yellow" "green"))
(define (pick-random lst)
  (list-ref lst (random (length lst)))
)

(define (square size color)
  (colorize (filled-rectangle size size) color))
;
;;;--------------------------------------------------------------------
;;; Реализация минимакса с альфа-бета отсечением
(define (minimax tree)
  (define (minimax-h node alpha beta max-player)
    (define (next-max x v)
      (if (or (null? x) (<= beta v))
                v
                (next-max (cdr x)
                      (max v (minimax-h (car x) v beta (not max-player)))))
    )
    (define (next-min x v)
      (if (or (null? x) (<= v alpha))
                v
                (next-min (cdr x)
                      (min v (minimax-h (car x) alpha v (not max-player)))))
    )
    (cond
         ((number? node) node)
         ((null? node) 0.0)
         (max-player (next-max node alpha))
         (else (next-min node beta)))

  )
  (minimax-h tree -inf.0 +inf.0 #f)
 )



;;;--------------------------------------------------------------------
;;; описание класса, реализующего логику и оптимальную стратегию произвольной игры с нулевой суммой и полной информацией
(define game%
  (class object%
    (super-new)

    ;; виртуальные методы для задания правил игры
    (init-field my-win?         ; State -> Bool
                my-loss?        ; State -> Bool
                draw-game?      ; State -> Bool
                my-move         ; State Move -> State
                opponent-move   ; State Move -> State
                possible-moves  ; State -> (list Move)
                show-state)     ; State -> Any

    ;; optimal-move :: State -> Move
    ;; выбор оптимального хода по минимаксу
    ;; из нескольких оптимальных выбирается один случайно
    (define/public ((optimal-move look-ahead) S)
      (argmax (lambda (m) (minimax (game-tree S m look-ahead))
                 (shuffle (possible-moves S)))))

    ;; game-tree :: State -> (Move -> (Tree of Real))
    ;; построение дерева с оценками
    (define (game-tree St m look-ahead)
       ;; вспомогательная функция, строящая закольцованный список из пары элементов
      (define (help a b) (begin (define l (mlist a b a)) (set-mcdr! l (mcons b l)) l))
      (define (new-ply moves i s)
        (cond
          ((my-win? s) +inf.0) ; в выигрышной позиции оценка = + бесконечность
          ((my-loss? s) -inf.0) ; в проигрышной = - бесконечность
          ((draw-game? s)     0) ; при ничье = 0
          ((>= i look-ahead)  (f-h s)) ; если исчерпана глубина, то используется эвристическая оценка
          (else (map (lambda (x) (new-ply (mcdr moves) (+ 1 i) ((mcar moves) s x)))
                     (possible-moves s))) ; рассматриваем все возможные ходы и строим их оценки
        ))
     (new-ply (help opponent-move my-move) 1 (my-move St m))
    )

    ;; make-move :: State (State -> Move) -> (Move State Symbol)
    (define/public (make-move S move)
      (display "make-move got ")
      (display S)
      (display "\n")
      (cond
        ((my-loss? S)   (values '() S 'loss))
        ((draw-game? S) (values '() S 'draw))
        (else (let* ((m* (move S))
                     (S* (my-move S m*))
                     )
                (cond
                  ((my-win? S*)    (values m* S* 'win))
                  ((draw-game? S*) (values m* S* 'draw))
                  (else (begin

      (display "make-move sent ")
      (display S*)
      (display "\n")

                   (values m* S* 'next)))))))
    )
  ))


;;;--------------------------------------------------------------------
;;; макрос для описания партнеров в игре
(define-syntax-rule
  (define-partners game (A #:win A-wins #:move A-move)
                        (B #:win B-wins #:move B-move))
  (begin
    (define A (class game
                (super-new
                 [my-win?  A-wins]
                 [my-loss? B-wins]
                 [my-move  A-move]
                 [opponent-move B-move])))
    (define B (class game
                (super-new
                 [my-win?  B-wins]
                 [my-loss? A-wins]
                 [my-move  B-move]
                 [opponent-move A-move])))))

;;;--------------------------------------------------------------------

;; Структура представляющая ситуацию на игровой доске. В структуре одно поле - вектор в котором находятся цвета ячеек
(struct board (colors))

;; геттер цветов ячеек
(define colors board-colors)

;; в начале игровая доска пуста, гарантируется, что начальные цвета двух игроков разные. игроки начинают в верхнем левом и нижнем правом углах
(define (make-board) (board  (list->vector (build-list (* field-size field-size) (lambda (x) (pick-random all-colors) )))))
(define (make-empty-board)
  (let ((b (make-board)))
    (if (eq? (vector-ref (colors b) 0) (vector-ref (colors b) (sub1 (* field-size field-size)))) (make-empty-board) b)))
(define empty-board (make-empty-board))

;; изменить цвет клетки по ее позиции в векторе`
(define (color-cell color number b)
  (vector-set! b number color))

;; получить цвет клетки по ее позиции в векторе
(define (cell-color number b)
  (vector-ref  b number))

;; получить список соседних клеток по номеру, возвращяются только клетки такого же цвета, что и центральная
;; разобрано 9 случаев: центральная часть поля, 4 угла, 4 границы без угловых клеток
(define (get-close-cells number b)
  (let ((color-of-cell (cell-color number b))
        (i (quotient number field-size))
        (j (remainder number field-size))
        (field-size-sub1 (sub1 field-size)))
    (cond ((and (> i 0) (> j 0) (< i field-size-sub1) (< j field-size-sub1)) (filter (lambda (x) (eq? (cell-color x b) color-of-cell)) (list
                                                                                                    (+ (* (+ 1 i) field-size) j)
                                                                                                    (+ (* (- i 1) field-size) j)
                                                                                                    (+ (* i field-size) (+ 1 j))
                                                                                                    (+ (* i field-size) (- j 1)))))

          ((and  (= i field-size-sub1) (> j 0) (< j field-size-sub1)) (filter (lambda (x) (eq? (cell-color x b) color-of-cell)) (list
                                                                                                    (+ (* i field-size) (+ 1 j))
                                                                                                    (+ (* (- i 1) field-size) j)
                                                                                                    (+ (* i field-size) (- j 1)))))
          ((and (= i 0) (> j 0) (< j field-size-sub1)) (filter (lambda (x) (eq? (cell-color x b) color-of-cell)) (list
                                                                                                    (+ (* (+ i 1) field-size) j)
                                                                                                    (+ (* i field-size) (+ 1 j))
                                                                                                    (+ (* i field-size) (- j 1)))))
          ((and (= j 0) (> i 0) (< i field-size-sub1)) (filter (lambda (x) (eq? (cell-color x b) color-of-cell)) (list
                                                                                                    (+ (* i field-size) (+ j 1))
                                                                                                    (+ (* (+ i 1) field-size) j)
                                                                                                    (+ (* (- i 1) field-size) j))))
          ((and (= j field-size-sub1) (> i 0) (< i field-size-sub1)) (filter (lambda (x) (eq? (cell-color x b) color-of-cell)) (list
                                                                                                    (+ (* i field-size) (- j 1))
                                                                                                    (+ (* (+ i 1) field-size) j)
                                                                                                    (+ (* (- i 1) field-size) j))))


          ((and (= i 0) (= j 0)) (filter (lambda (x) (eq? (cell-color x b) color-of-cell)) (list
                                                                                                    (+ (* (+ i 1) field-size) j)
                                                                                                    (+ (* i field-size) (+ j 1)))))
          ((and (= i field-size-sub1) (= j 0)) (filter (lambda (x) (eq? (cell-color x b) color-of-cell)) (list
                                                                                                    (+ (* (- i 1) field-size) j)
                                                                                                    (+ (* i field-size) (+ j 1)))))
          ((and (= i 0) (= j field-size-sub1)) (filter (lambda (x) (eq? (cell-color x b) color-of-cell)) (list
                                                                                                    (+ (* (+ i 1) field-size) j)
                                                                                                    (+ (* i field-size) (- j 1)))))
          ((and (= i field-size-sub1) (= j field-size-sub1)) (filter (lambda (x) (eq? (cell-color x b) color-of-cell)) (list
                                                                                                   (+ (* (- i 1) field-size) j)
                                                                                                    (+ (* i field-size) (- j 1)))))
           )))

;; закрасить клетки поля в заданный цвет по принципу flood-fill
;; закрашиваются только те клетки, которые имеют тот же цвет, что и начальная, и  существует путь от этой клетки до начальной, на котором все клетки имеют цвет начальной
;; на вход подается цвет закраски и номер начальной клетки
(define (flood-fill11 color number b)
  (define (helper  to-go visited)
    (cond ((null? to-go) '())
          ((member (car to-go) visited) (helper (cdr to-go) visited))
          (else (helper (append (filter (lambda (x) (not (member x visited))) (get-close-cells (car to-go) b)) (cdr to-go)) (cons (car to-go) visited))
                (color-cell color (car to-go) b))))
  (helper (list number) '())
  (copy-vector b)
  )

(define (flood-fill color number b)
  (display b)
  (display "\n")
  (define (helper0 b res)
    (cond ((null? b) (list->vector (reverse res)))
          (else (helper0 (cdr b) (cons (car b) res)))))
  (define (helper b to-go visited to-change)
    (cond ((null? to-go) to-change)
          ((member (car to-go) visited) (helper b (cdr to-go) visited to-change))
          (else (helper b (append (filter (lambda (x) (not (member x visited))) (get-close-cells (car to-go) b)) (cdr to-go)) (cons (car to-go) visited) (cons (car to-go) to-change)))))
  (define (helper2 color colors numbers to-change result)
    (cond ((null? colors) result)
          ((member (car numbers) to-change) (helper2 color (cdr colors) (cdr numbers) to-change (cons color result)))
          (else (helper2 color (cdr colors) (cdr numbers) to-change (cons (car colors) result)))))
  (display (helper (helper0 (vector->list b) '()) (list number) '() '()))
  (display "\n")
  (display (helper (helper0 (vector->list b) '()) (list number) '() '()))
  (display "\n")
  ;(show-board (helper0 (vector->list b) '()))
  (display "\n")
  (display (list->vector (reverse (helper2 color (vector->list b) (build-list (* field-size field-size) (lambda (x) x)) (helper (helper0 (vector->list b) '()) (list number) '() '()) '()))))
  (display "\n")
  (list->vector (reverse (helper2 color (vector->list b) (build-list (* field-size field-size) (lambda (x) x)) (helper (helper0 (vector->list b) '()) (list number) '() '()) '())))
  ;(copy-vector b)
  )

;(build-list (* field-size field-size) (lambda (x) (pick-random all-colors) ))
;; возвращяет размер региона одного цвета, которому принадлежит ячейка с указанным номером
(define (color-region-size number b)
    (define (helper  to-go visited size-accum)
    (cond ((null? to-go) size-accum)
          ((member (car to-go) visited) (helper (cdr to-go) visited size-accum))
          (else (helper (append (filter (lambda (x) (not (member x visited))) (get-close-cells (car to-go) b)) (cdr to-go)) (cons (car to-go) visited) (+ 1 size-accum)))))
  (helper (list number) '() 0))



;; проверка, является ли ситуация на игровой доске выигрышной для региона цвета, которому принадлежит ячейка с указанным номером
(define ((wins? number) b)
  (>=  (color-region-size number b)  (/ (* field-size field-size) 2 )))


;; проверка на ничью, она возможна только в одном случае - когда размер региона каждого игроока равен ровно половине размера поля
(define (draw? b)
  (let ((half-size (/ (* field-size field-size) 2))
        (last-cell (- (* field-size field-size) 1)))
    (and (= (color-region-size 0 b) half-size) ((= (color-region-size last-cell b) half-size)))))

;; функция эвристической оценки позиции
;; из количества линий, открытых для крестиков, вычитается количество линий, открытых для ноликов
(define (f-h s)
  0
)


(define (full-copy list)
(if (null? list)
  '()
  (if (list? list)
      (cons (full-copy (car list)) (full-copy (cdr list)))
      list)))

(define (copy-vector v)
  (list->vector (full-copy (vector->list v))))

(define (copy-board b)
  (board (list->vector (full-copy (vector->list (colors b))))))



;; функции для осуществления ходов игроков
(define (a-move b color)  (copy-vector (flood-fill color 0 (copy-vector b))))
(define (b-move b color)  (copy-vector (flood-fill color (- (* field-size field-size) 1) (copy-vector b))))


(define (show-board b)
  (for ([i (build-list field-size (lambda (x) x))])
    (for ([j (build-list field-size (lambda (x) x))])
      (print (square 20 (vector-ref b (+ (* i field-size) j))))
      (display " "))
    (display "\n"))
)


;;--------------------------------------------------------------------
;; Описание класса-игры крестики-нолики
(define filler%
  (class game%
    (super-new
     [draw-game?       draw?]
     [possible-moves   all-colors]
     [show-state       show-board])))

;; описания партнеров для крестиков-ноликов
(define-partners filler%
  (playera% #:win (wins? 0) #:move a-move)
  (playerb% #:win (wins? (- (* field-size field-size) 1)) #:move b-move))


;;--------------------------------------------------------------------
;; Реализация класса игрока
;; Параметр `game` указывает, в какая игра решается.
(define (interactive-player game)
  (class game
    (super-new)

    (inherit-field show-state)
    (inherit make-move optimal-move)

    (init-field name
                [look-ahead 4]
                [opponent 'undefined]
                [move-method (optimal-move look-ahead)])

    (define/public (your-turn S1)
      (define-values (m S status) (make-move S1 move-method))
      (printf "\n~a makes move ~a\n" name m)
      (show-state S)
      (case status
           ['stop (displayln "The game was interrupted.")]
           ['win  (printf "~a wins!" name)]
           ['loss (printf "~a wins!" name)]
           ['draw (printf "Draw!")]
           [else (send opponent your-turn S)]))))
           ;[else (send opponent your-turn (board (vector-copy (colors S*))))])))))


;;--------------------------------------------------------------------


;; объекты-игроки, принимающие ввод пользователя
;; проверка ввода частичная
(define (input-move m)
  (cond ((eq? m 'q) (exit))
        ((member m all-colors) m)
        (else m)))

(define user-A
  (new (force (interactive-player playera%))
       [name "User A"]
       [move-method
        (lambda (b) (input-move (read)))]
        )
 )
(define user-B
  (new (force (interactive-player playerb%))
       [name "User B"]
       [move-method
        (lambda (b) (input-move (read)))]
        )
 )

;;--------------------------------------------------------------------
;; функция, инициализирующая игру
(define (start-game p1 p2 initial-state)
  (set-field! opponent p1 p2)
  (set-field! opponent p2 p1)
  (send p1 your-turn initial-state))
;; пример использования
(show-board (colors empty-board))
(start-game user-A user-B (colors empty-board))

;
;(define b empty-board)
;(show-board b)
;
;(define point 0)
;
;(define (black)
;  (flood-fill "black" point b)
;  (show-board b))
;(define (red)
;  (flood-fill "red" point b)
;  (show-board b))
;(define (green)
;  (flood-fill "green" point b)
;  (show-board b))
;(define (yellow)
;  (flood-fill "yellow" point b)
;  (show-board b))
;(define (blue)
;  (flood-fill "blue" point b)
;  (show-board b))
;(define (teal)
;  (flood-fill "teal" point b)
;  (show-board b))
;(define (orange)
;  (flood-fill "orange" point b)
;  (show-board b))