(defconstant shirina 7);Ширина доски
(defconstant dlina 6);Длина доски
(defconstant white_pobeda 1000000) ;Границы
(defconstant krasnie_pobeda -1000000);Границы
(defparameter *debug* nil) ;Выключить режим отладки
(defparameter *maxglubina* 7) ;Максимальная глубина эвристики

; Ускоряем программу путем подачи параметров компилятору, из-за которых он будет считать, что все что мы ему
;будем указывать, например принудительные типы переменных соотвествует истине
(declaim (optimize (speed 3) (safety 0) (debug 0)))

(defun predikat-operation (x)
(member x '(+ 1+ - 1- * /))) ;Проверяем, что x соответствует элементу из списка операций

(defun proverka (sexpr)
(cond ;Проверка нескольких условий
((listp sexpr) ;Проверяем что выражение-аргумент это список
(if (null sexpr) ;Если оно равно пустому списку, то возвращаем пустой список
()
(let ((hd (car sexpr)) ;Иначе присваиваем переменной голову списка
(tl (cdr sexpr)));Другой переменной хвост списка
(cond ;Проверка нескольких условий
((listp hd) (append (list (proverka hd)) (proverka tl))) ;проверяем что голова тоже список и тогда соединяем два списка с помощью рекурсии
((predikat-operation hd) (list 'the 'fixnum (cons hd (proverka tl)))) ;Если голова не список но является одним знаков операций создаем
;список, соединив элемент головы и в результат рекурсии от хвоста
(t (cons hd (proverka tl))))))) ;в любом случае соединяем голову и результат рекурсии от хвоста
(t sexpr))) ;и возвращаем выражение

; Для нужной скорости нам необходимо указать в некоторых местах,
; что результат операции помещается в fixnum
; Поэтому создаем специальный макрос
(defmacro bistree (&rest sexpr)
`(,@(proverka sexpr)))

(defmacro at (y x)
; Мы эмулируем доску 7 на 6 - одномерную
(let ((final (proverka (list '+ (list '* 7 y) x))))
`(aref doska ,final)))

; Функция tablo добавляет значения на 4 подряд
; клетки, и, следовательно, результат простирается от -4 до 4 (9 значений)
; Этот макрос обновляет "counts", из них 9 можно
; выделить значения (накопленные частоты значений)
(defmacro myincrement ()
`(incf (aref counts (+ 4 score)))) ;aref извлекает из массива counts элемент номера 4 + score и прибавляет к нему единицу

;Следующие макросы позволяют производить расчеты ещё при компиляции.
;Пройдемся по горизонтальным ячейкам
(defmacro horizont-yacheiki ()
`(progn
(let ((score 0))
(declare (type fixnum score))
,@(loop for y fixnum from 0 to (1- dlina)
; Первые 3 из четырёх клеток
collect `(setf score (+ (at ,y 0) (at ,y 1) (at ,y 2)))
nconc (loop for x fixnum from 3 to (1- shirina)
; Добавим 4-ой один
collect `(incf score (at ,y ,x))
; Обновим значения
collect `(myincrement)
; Если мы снова все ещё в пределах то удалить первый старого 4
if (/= x (1- shirina))
collect `(decf score (at ,y ,(- x 3))))))))

;Пройдемся по вертикальным ячейкам
(defmacro verticalni-yacheiki ()
`(progn
(let ((score 0))
(declare (type fixnum score))
,@(loop for x fixnum from 0 to (1- shirina)
; Первые 3 из четырёх клеток
collect `(setf score (+ (at 0 ,x) (at 1 ,x) (at 2 ,x)))
nconc (loop for y fixnum from 3 to (1- dlina)
; Добавим 4-ой один
collect `(incf score (at ,y ,x))
; Обновим значения
collect `(myincrement)
; Если мы снова все ещё в пределах то удалить первый старого 4
if (/= y (1- dlina))
collect `(decf score (at ,(- y 3) ,x)))))))

;Пройдемся по диагональным справа вниз ячейкам
(defmacro sprava-vniz-yacheiki ()
(let ((y 0)
(x 0))
(declare (type fixnum y x))
`(progn
(let ((score 0))
(declare (type fixnum score))
; якоря, чтобы начать расчет score4s при движении вниз право
,@(let ((dr '((2 0) (1 0) (0 0) (0 1) (0 2) (0 3))))
(loop for startposTuple in dr
do (setf y (car startposTuple)) (setf x (cadr startposTuple))
; первые 3 от общего объема 4 клеток
collect `(setf score (bistree + (at ,y ,x) (at ,(bistree 1+ y) ,(bistree 1+ x)) (at ,(bistree + y 2) ,(bistree + x 2))))
nconc (loop while (and (<= (+ y 3) (1- dlina)) (<= (+ x 3) (1- shirina)))
; Добавим 4-ой один
collect `(incf score (at ,(bistree + y 3) ,(bistree + x 3)))
; Обновим значения
collect `(myincrement)
; Двигаемся к следующей клетке
do (incf y) (incf x)
; Если мы снова все ещё в пределах то удалить первый старого 4
if (and (<= (+ y 3) (1- dlina)) (<= (+ x 3) (1- shirina)))
collect `(decf score (at ,(bistree 1- y) ,(bistree 1- x))))))))))

;Пройдемся по диагональным слева вниз ячейкам
(defmacro vniz-sleva-yacheiki ()
(let ((y 0)
(x 0))
(declare (type fixnum y x))
`(progn
(let ((score 0))
(declare (type fixnum score))
; якоря, чтобы начать расчет score4s при движении вниз влево
,@(let ((dl '((0 3) (0 4) (0 5) (0 6) (1 6) (2 6))))
(loop for startposTuple in dl
do (setf y (car startposTuple)) (setf x (cadr startposTuple))
; первые 3 от общего объема 4 клеток
collect `(setf score (bistree + (at ,y ,x) (at ,(bistree 1+ y) ,(bistree 1- x)) (at ,(bistree + y 2) ,(bistree - x 2))))
nconc (loop while (and (<= (+ y 3) (1- dlina)) (>= (- x 3) 0))
; Добавим 4-ой один
collect `(incf score (at ,(bistree + y 3) ,(bistree - x 3)))
; Обновим значения
collect `(myincrement)
; Двигаемся к следующей клетке
do (incf y) (decf x)
; Если мы снова все ещё в пределах то удалить первый старого 4
if (and (<= (+ y 3) (1- dlina)) (>= (- x 3) 0))
collect `(decf score (at ,(bistree 1- y) ,(bistree 1+ x))))))))))

(declaim (inline tablo)) ;Управляющая команда для компилятора насчет функции tablo
(defun tablo (doska)
(declare (type (simple-array fixnum (42)) doska))
(let ((counts (make-array '(9) :initial-element 0 :element-type 'fixnum)))
; Мы добавляем значения Доски на 4 последовательные клетки, и, следовательно,
; получаем результат, который может быть от -4 до 4 (9 возможных значений).
; Мы затем обновляем массив баллов, из них можно извлечь 9
; значений (совокупные частоты значений видел).
; Это делается с помощью следующих 4 макросов
(horizont-yacheiki)
(verticalni-yacheiki)
(sprava-vniz-yacheiki)
(vniz-sleva-yacheiki)

(cond
((/= (aref counts 0) 0) krasnie_pobeda)
((/= (aref counts 0) white_pobeda)
(t (let* ((forwhite (bistree + (aref counts 5)
(* 2 (aref counts 6))
(* 5 (aref counts 7))))
(forKrasnie (bistree + (aref counts 3)
(* 2 (aref counts 2))
(* 5 (aref counts 1))))
(result (bistree - forwhite forKrasnie)))
(declare (type fixnum forwhite forKrasnie result))
result)))))
(declaim (inline doska_cherez_hod)) ;Управляющая команда для компилятора насчет функции doska_cherez_hod
;Функция для создания новой доски, такой какой она будет через ход
(defun doska_cherez_hod (doska column color)
(declare (type (simple-array fixnum (42)) doska) (type fixnum column color))
(loop for y fixnum from (1- dlina) downto 0
do (cond ((= 0 (at y column))
(progn
(setf (at y column) color)
(return-from doska_cherez_hod y)))))
-1)
;Функция для алгоритма Минимакс, которая принимает четыре параметры, к примеру цвет, глубину эвристики и нашу доску, которая является массивом
(defun minimax_algoritm (maximizeOrMinimize color depth doska)
(declare (type fixnum color depth) (type (simple-array fixnum (42)) doska))
(let ((bestScore (cond (maximizeOrMinimize krasnie_pobeda) (t white_pobeda)))
(bestMove -1)
(killerTarget (cond (maximizeOrMinimize white_pobeda) (t krasnie_pobeda))))
(declare (type fixnum bestScore bestMove))
(loop for column fixnum from 0 to (1- shirina)
do (if (= 0 (at 0 column))
(let ((rowFilled (doska_cherez_hod doska column color))
(s (tablo doska)))
(cond
((= s killerTarget) (progn
(setf (at rowFilled column) 0)
(return-from minimax_algoritm (list column s))))
(t (progn
(let* ((result (cond
((= depth 1) (list column s))
(t (minimax_algoritm (not maximizeOrMinimize) (- color) (1- depth) doska))))
(scoreInner (cadr result))
(shiftedScore
; Когда существует потеря, удерживаем путем сдвига балло по глубине
(if (or (= scoreInner white_pobeda) (= scoreInner krasnie_pobeda))
(- scoreInner (bistree * depth color))
scoreInner)))
(declare (type fixnum scoreInner shiftedScore *maxglubina*))
(setf (at rowFilled column) 0)
(if (and *debug* (= depth *maxglubina*))
(format t "Glubina ~A, raspologena ~A, Ball:~A~%" depth column shiftedScore))
(if maximizeOrMinimize
(if (>= shiftedScore bestScore)
(progn
(setf bestScore shiftedScore)
(setf bestMove column)))
(if (<= shiftedScore bestScore)
(progn
(setf bestScore shiftedScore)
(setf bestMove column)))))))))))
(list bestMove bestScore)))

;Функция для загрузки доски в переменную в главной функции
(defun doska_zagruzka (argumenti)
(declare (type list argumenti))
(let ((doska (make-array 42 :initial-element 0 :element-type 'fixnum)))
(format t "~A~%" argumenti)
(loop for y fixnum from 0 to (1- dlina)
do (loop for x fixnum from 0 to (1- shirina)
do (let ((white (format nil "o~A~A" y x))
(krasnie (format nil "y~A~A" y x)))
(if (find white argumenti :test #'equal)
(setf (at y x) 1))
(if (find krasnie argumenti :test #'equal)
(setf (at y x) -1)))))
doska))

(defun skorost ()
(let
; Мы эмулируем доску 7 на 6 - одномерную
((doska (make-array 42 :initial-element 0 :element-type 'fixnum)))
(setf (at 5 3) 1)
(setf (at 4 3) -1)
(dotimes (n 10)
(time (format t "~A" (minimax_algoritm t 1 *maxglubina* doska))))))

;Берем аргументы командной строки из глобальных переменных в зависимости от типа используемого интерпретатора
(defun argumenti-commandnoy ()
(or
#+SBCL *posix-argv*
#+LISPWORKS system:*line-arguments-list*
#+CMU extensions:*command-line-words*
nil))

(defun main ()
(let ((argumenti (argumenti-commandnoy))
(exitCode 0))
(declare (type list argumenti))
(cond
; Нет аргументов?
((<= (length argumenti) 1)
; значит делаем проверку скорости расчетов по алгоритму
(progn
(format t "Skorost...~%")
(skorost)))
; Считываем аргументы в функцию загрузки доски
(t (let* ((doska (doska_zagruzka argumenti))
(scoreOrig (tablo doska)))
; Задаем режим отладки, если задан такой ключ
(if (find "-debug" argumenti :test #'equal)
(setf *debug* t))
(if *debug* (format t "Nachinaem: ~A~%" scoreOrig))
; Проверяем состояние доски на победу или проигрыш
(cond ((= scoreOrig white_pobeda)
(progn
(print "Я выиграл")
(setf exitCode -1)))
((= scoreOrig krasnie_pobeda)
(progn
(print "Вы выиграли")
(setf exitCode -1)))
; Если мы не проиграли или не выиграли то используем алгоритм минимакс
(t (let ((result (minimax_algoritm t 1 *maxglubina* doska)))
(format t "~A~%" (car result))
(setf exitCode 0)))))))
exitCode))