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

;;--------------------------------------------------------------------
;; Реализация минимакса с альфа-бета отсечением
(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
                show-state      ; State -> Any
                possible-moves  ; State -> (list Move)
                [number 'undefined]
                )

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

    ;; 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 number))) ; рассматриваем все возможные ходы и строим их оценки
        ))
     (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)
      (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            (values m* S* 'next))))))
    )
  ))

;;--------------------------------------------------------------------
;; Реализация класса игрока
;; Параметр `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 S)
      (define-values (m S* status) (make-move S 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*)])))))


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


;;--------------------------------------------------------------------
;; Описания крестиков-ноликов

;; Структура представляющая ситуацию на игровой доске. В структуре три поля -- список точек фигуры крсного игрока, список точек фигуры синего игрока, две точки черных фишек
(struct board (l1 l2 os))

;; геттеры полей структуры
(define l1 board-l1)
(define l2 board-l2)
(define os board-os)

;; начальная игровая доска
(define empty-board (board (list 1 2 6 10) (list 5 9 13 14) (list 0 15)))


; move - starting_point rotation variation new_blacks

; получить список точек фигуры игрока после применения хода, если при применении такого хода фигуры выходит за пределы игрового поля,
; то тем частям, которые вышли за пределы поля присваивается -1
(define (l-points-for-move move)
  ; вспомогательные функции - возвращают номер соседней клетки или -1, если она за пределами игрового поля
  (define (up point)
    (if (< point 4)
        -1
        (- point 4)))
  (define (down point)
    (if (> point 11)
        -1
        (+ point 4)))
  (define (left point)
    (if (< (remainder point 4) 1)
        -1
        (- point 1)))
  (define (right point)
    (if (> (remainder point 4) 2)
        -1
        (+ point 1)))
  (let ((base (car move)))
          (cond
            ((and (= (cadr move) 0) (= (caddr move) 0)) (list base (up base) (up (up base)) (right base)))
            ((and (= (cadr move) 0) (= (caddr move) 1)) (list base (up base) (right (right base)) (right base)))

            ((and (= (cadr move) 1) (= (caddr move) 0)) (list base (right base) (down base) (right (right base))))
            ((and (= (cadr move) 1) (= (caddr move) 1)) (list base (right base) (down base) (down (down base))))

            ((and (= (cadr move) 2) (= (caddr move) 0)) (list base (down base) (left base) (down (down base))))
            ((and (= (cadr move) 2) (= (caddr move) 1)) (list base (down base) (left base) (left (left base))))

            ((and (= (cadr move) 3) (= (caddr move) 0)) (list base (left base) (up base) (left (left base))))
            ((and (= (cadr move) 3) (= (caddr move) 1)) (list base (left base) (up base) (up (up base)))))))

; проверка на то, что фигура находится целиком на игровом поле
(define (l-points-valid? points)
  (andmap (lambda (x) (>= x 0)) points))

; проверка на то, что данный ход является допустимым
(define (valid-move? b move player-num)
  (let* ((l-points (l-points-for-move move)) ; точки, которые займет фигура игрока после перемещения
         (new-blacks (cadddr move))) ; новые точки черных фигур

    (and
         ; не вышло за границу игрового поля
         (l-points-valid? l-points)

         ; две черных фигуры не слились в одну
         (not (= (car new-blacks) (cadr new-blacks)))

         ; новая позиция фигуры игрока не пересекается с фигурой противника
         (cond ((= player-num 1) (andmap (lambda (x) (not (member x (l2 b)))) l-points))
               ((= player-num 2) (andmap (lambda (x) (not (member x (l1 b)))) l-points)))

         ; новая позиция фигуры игрока хотя бы на одну клетку отличается от старой
         (cond ((= player-num 1) (ormap (lambda (x) (not (member x (l1 b)))) l-points))
               ((= player-num 2) (ormap (lambda (x) (not (member x (l2 b)))) l-points)))

         ; новая позиция фигуры игрока не пересекается с черными фигурами
         (andmap (lambda (x) (not (member x (os b)))) l-points)

         ; только одна из черных фигур поменяла позицию
         (or (= (car new-blacks) (car (os b)))
             (= (cadr new-blacks) (car (os b)))
             (= (car new-blacks) (cadr (os b)))
             (= (cadr new-blacks) (cadr (os b))))

         ; новые позиции черных фигур не пересекаются с фигурами игроков
         (cond ((= player-num 1) (andmap (lambda (x) (and (not (member x (l2 b))) (not (member x l-points)))) new-blacks))
               ((= player-num 2) (andmap (lambda (x) (and (not (member x (l1 b))) (not (member x l-points)))) new-blacks)))

         )))

; сделать ход
(define (make-move b move player-num)
  (let ((l-points (l-points-for-move move)))
    (cond ((= player-num 1) (board l-points (l2 b) (cadddr move)))
          ((= player-num 2) (board (l1 b) l-points (cadddr move))))))

; вспомогательная функция, возвращает список точек игрового поля, которые не принадлежат игроку с указанным номером
(define (points-not-under-number b number)
  (filter (lambda (x) (and (not (member x (os b)))
                           (cond
                             ((= number 1) (not (member x (l2 b))))
                             ((= number 2) (not (member x (l1 b))))
                             ))) (build-list 16 (lambda (x) x))))
; вспомогательная функция, возвращает список точек игрового поля, на которых нет черных фигур
(define (points-not-under-black b)
  (filter (lambda (x) (and (not (member x (os b))))) (build-list 16 (lambda (x) x))))


;; проверка, является ли ситуация на игровой доске выигрышной
; ситуация является выигрышной только в одном случае - противник не может сделать хода своей фигурой
; эта функция для каждой открытой клетки пытается на ней разместить угол фигуры противника, а затем проверяет, является ли это легальным ходом
; как только хотя бы один такой ход найден - значит ситуация не является выигрышной - перебор прекращается
(define ((wins? player-num) b)
  (let* ((open-points (points-not-under-number b (if (= player-num 1) 2 1)))
         (possible-moves (cartesian-product open-points (list 0 1 2 3) (list 0 1) (list (os b))))
         (opponent-num (if (= player-num 1) 2 1)))
    (not (ormap (lambda (x) (valid-move? b x opponent-num)) possible-moves))
    ))


; получить список всех легальных ходов для игрока с указанным номером
; сначала происходит перебор всех возможных ходов фигурой игрока, отбираются только легальные
; затем для каждого найденного хода фигурой добавляются всевозможные ходы черной фигурой (в том числе бездействие)
(define (valid-moves b player-num)
  (let* ((open-points (points-not-under-number b player-num))
         (all-points (build-list 16 (lambda (x) x)))
         (possible-moves (cartesian-product open-points (list 0 1 2 3) (list 0 1) (list (os b))))
         (possible-l-moves (filter (lambda (x) (valid-move? b x player-num)) possible-moves)))

    (filter (lambda (x) (valid-move? b x player-num))
            (append possible-l-moves
                    (map (lambda (x) (list (car (car x)) (cadr (car x)) (caddr (car x)) (list (cadr x) (cadr (cadddr (car x)))) )) (cartesian-product possible-l-moves open-points))
                    (map (lambda (x) (list (car (car x)) (cadr (car x)) (caddr (car x)) (list (car (cadddr (car x))) (cadr x)) )) (cartesian-product possible-l-moves open-points))))))

;; функция эвристической оценки позиции
; поскольку считать количество ходов получается очень долго - функция такая
; если открыть страницу этой игры в википедии, то можно заметить, что в 12 из 15 позиций, где игрок проигрывает,
; его фигура находится в углу
(define (f-h b)

    (+ (if (or
         (and (member 0 (l2 b)) (member 1 (l2 b)) (member 4 (l2 b)))
         (and (member 2 (l2 b)) (member 3 (l2 b)) (member 7 (l2 b)))
         (and (member 15 (l2 b)) (member 14 (l2 b)) (member 11 (l2 b)))
         (and (member 8 (l2 b)) (member 12 (l2 b)) (member 13 (l2 b))))
        -100
        0)
       (if (or
         (and (member 0 (l1 b)) (member 1 (l1 b)) (member 4 (l1 b)))
         (and (member 2 (l1 b)) (member 3 (l1 b)) (member 7 (l1 b)))
         (and (member 15 (l1 b)) (member 14 (l1 b)) (member 11 (l1 b)))
         (and (member 8 (l1 b)) (member 12 (l1 b)) (member 13 (l1 b))))
        100
        0
        )))

;; функции для осуществления ходов игроков
(define (red-move b m)  (make-move b m 1))
(define (blue-move b m) (make-move b m 2))

;; вывод игровой доски
(define (show-board b)
  (for ([i (list 0 1 2 3)])
    (for ([j (list 0 1 2 3)])
      (display (~r (+ (* i 4) j) #:min-width 2 #:pad-string " ") )

      (print (colorize (filled-rectangle 40 40) (cond
                                                  ((member (+ (* i 4) j) (l1 b)) "red")
                                                  ((member (+ (* i 4) j) (l2 b)) "blue")
                                                  ((member (+ (* i 4) j) (os b)) "black")
                                                  (else "gray"))))
      )
    (display "\n")))

;(set! empty-board (board (list 12 13 14 8) (list 2 6 10 9) (list 4 3)))
;(show-board empty-board)
;((wins? 2) empty-board)
;(valid-move? empty-board (list 3 2 0 (list 0 12)) 2)
;(show-board (make-move empty-board (list 3 2 0 (list 0 12)) 2))

;;--------------------------------------------------------------------
;; Описание класса-игры крестики-нолики
(define lgame%
  (class game%
    (super-new
     [draw-game?       (lambda (x) #f)]
     [show-state       show-board]
     [possible-moves valid-moves])))

;; описания партнеров для крестиков-ноликов
(define-partners lgame%
  (red% #:win (wins? 1) #:move red-move #:number 1)
  (blue% #:win (wins? 2) #:move blue-move #:number 2))

;;; объекты-игроки ИИ
(define player-A (new (force (interactive-player red%)) [name "Red"] [look-ahead 3] ))

(define player-B (new (force (interactive-player blue%)) [name "Blue"] [look-ahead 3]))

;; функция получения хода
(define (input-move b  player-num)
  (printf "Plese enter your move like that (base rotation variation black1 black2): ")
  (let ((m (read)))
  (cond ((or (not (pair? m)) (not (= (length m) 5))) (input-move b player-num))
        (else
  (let ((move (list (car m) (cadr m) (caddr m) (list (cadddr m) (cadddr (cdr m))))))
  (cond ((valid-move? b move player-num) move)
        (else (printf "Invalid move\n")  (input-move b  player-num))))))
))

(define user-A
  (new (force (interactive-player red%))
       [name "Red Player"]
       [move-method
        (lambda (b) (input-move b  1))]
        )
 )
(define user-B
  (new (force (interactive-player blue%))
       [name "Blue Player"]
       [move-method
        (lambda (b) (input-move b 2))]
        )
 )


;;--------------------------------------------------------------------
;; функция, инициализирующая игру
(define (start-game p1 p2 initial-state)
  (printf "Каждая клета игрового поля имеет номер от 0 до 15\n")
  (printf "Первым ходит красный игрок\n")
  (printf "Ход игрока имеет следующий вид: (база поворот тип черная1 черная2)\n")
  (printf "база - номер клетки, где должен находиться угол фигуры после хода\n")
  (printf "поворот - (принимает значения 0 1 2 3), 0 - у базовой клетки есть соседи сверху и справа, 1 - справа и снизу, 2 - низ и лево, 3 - лево и верх\n")
  (printf "    (базовая клетка - это угол фигуры)\n")
  (printf "тип - принимает значения 0 и 1,\n")
  (show-board initial-state)
  (set-field! opponent p1 p2)
  (set-field! opponent p2 p1)
  (send p1 your-turn initial-state))

(define (start)
  (printf "Choose game mode (1, 2 or 3):\n1. Human vs Human\n2. AI vs AI\n3.Human vs AI\n")
  (let ((choice (read)))
    (cond
      ((and (integer? choice) (= choice 1)) (!(start-game user-A user-B empty-board)))
      ((and (integer? choice) (= choice 2)) (!(start-game player-A player-B empty-board)))
      ((and (integer? choice) (= choice 3)) (!(start-game user-A player-B empty-board)))
      (else (start )))))
(start)
;(show-board empty-board)
;(!(start-game player-A player-B empty-board))

;(define testboard (board (list 1 2 3 7) (list 6 8 9 10) (list 0 15)))
;(show-board testboard)
;(valid-moves testboard 1)
;((wins? 2) testboard)