;;;------------------------------------------------------------
;;; Gerenciador de campeonato
;;;
;;; Modificado em 04/11/2000 para xlisp de PC
;;; Modificado em 11/09/2000 para jogo de Connect Four
;;;
;;; Modificado em 11/08/99 para jogo de OPOSICAO
;;; Modificado em 07/09/97 havia um erro que impedia que a
;;;                        funcao GATO-INICIA fosse chamada
;;; Modificado em 22/08/97 para jogo de  GATOS E RATO
;;;
;;; Funcao principal: chama-se campeonato
;;;
;;; Recebe uma lista de nomes de pacotes e promove um campeonato
;;; entre os ditos cujos.  Cada pacote devera' possuir as funcoes
;;; necessarias para promover partidas entre os pacotes.
;;; Todos jogam contra todos.  O valor retornado por campeonato
;;; e' uma lista contendo o placar final, no seguinte formato:
;;;
;;; ( (jog1 nvit nemp nderr ndesclass)
;;;   (jog2 nvit nemp nderr ndesclass)
;;;    ...
;;;   (jogn nvit nemp nderr ndesclass)
;;; )
;;;
;;; onde (jog1 jog2 ... jogn) e' a lista de entrada e nvit, nemp,
;;; nderr e ndesclass sao, respectivamente, o numero de vitorias,
;;; empates, derrotas e desclassificacoes que cada jogador teve.
;;;
;;; Obs.: Cada par de jogadores joga duas partidas para que cada
;;; jogador tenha a chance de jogar tanto como  Branco  quanto como
;;; Preto .  O  Branco  sempre comeca.

(setf *placar* nil)

(defmacro incf (a)
  `(setf ,a (1+ ,a))
  )

(defun campeonato (jogadores)
  "Recebe lista de jogadores; retorna placar final"

  ;; inicializa placar - tudo zero
  (setf *placar* (placar-inicial jogadores))

  ;; joga todos contra todos
  ;; serao jogadas (n*n - n) partidas (quadrado todo menos a diagonal)
  (dolist (jog1 jogadores)
	  (dolist (jog2 jogadores)
		  (unless (equal jog1 jog2)
			  (terpri)
			  (carrega jog1)
			  (carrega jog2)
			  (format t "~s versus ~s" jog1 jog2)
			  (terpri)
			  (registra jog1
				    jog2
				    (print
				     (partida-por-nome jog1 jog2)
				     )
				    *placar*)
			  (terpri)
			  (tira-tudo (list jog1 jog2))
			  )
		  )
	  )
  *placar*
  )

;;;------------------------------------------------------------
;;; Placar-inicial: tudo zerado

(defun placar-inicial (jogadores)
  (if (null jogadores)
      nil
    (cons (list (car jogadores) 0 0 0 0)
	  (placar-inicial (cdr jogadores))
	  )
    )
  )

;;;------------------------------------------------------------
;;; Funcao registra: atualiza o placar com o resultado de uma
;;; partida.  Entrada: jog1 jog2 resultado placar.  Saida:
;;; nao importa.  O importante e' o efeito colateral na variavel
;;; placar.
;;; Possiveis resultados: veja comentario na funcao PARTIDA

(defun registra (jog1 jog2 resultado placar)
  (cond
   ((equal (car resultado) 'empate)
    ;; numero de empates e' o terceiro da lista
    (incf (third (assoc jog1 *placar*)))
    (incf (third (assoc jog2 *placar*)))
    )
   ((equal (car resultado) 'vitoria)
    (when (equal (second resultado) 'branco)
	  ;; BRANCO, ou seja, jog1, ganhou
	  ;; numero de vitorias e' o segundo da lista
	  (incf (second (assoc jog1 *placar*)))
	  ;; numero de derrotas e' o quarto da lista
	  (incf (fourth (assoc jog2 *placar*)))
	  )
    (when (equal (second resultado) 'preto)
	  ;; PRETO, ou seja, jog2, ganhou
	  ;; numero de vitorias e' o segundo da lista
	  (incf (second (assoc jog2 *placar*)))
	  ;; numero de derrotas e' o quarto da lista
	  (incf (fourth (assoc jog1 *placar*)))
	  )
    )
   ((equal (car resultado) 'desclassificado)
    (when (equal (second resultado) 'branco)
	  ;; BRANCO, ou seja, jog1, foi desclassificado
	  ;; numero de desclassificacoes e' o quinto da lista
	  (incf (fifth (assoc jog1 *placar*)))
	  ;; numero de vitorias e' o segundo da lista
	  (incf (second (assoc jog2 *placar*)))
	  )
    (when (equal (second resultado) 'preto)
	  ;; PRETO, ou seja, jog2, foi desclassificado
	  ;; numero de vitorias e' o segundo da lista
	  (incf (second (assoc jog1 *placar*)))
	  ;; numero de desclassificacoes e' o quinto da lista
	  (incf (fifth (assoc jog2 *placar*)))
	  )
    )
   (t
    (print "Resultado invalido: ")
    (print resultado)
    )
   )
  )

;;;------------------------------------------------------------
;;; Partida-por-nome: o mesmo que partida, mas so' que recebe
;;; apenas os nomes dos pacotes que vao jogar, e nao as funcoes.

(defun partida-por-nome (jog1 jog2)
  (partida (symbol-function (find-symbol "BRANCO-INICIA" jog1))
	   (symbol-function (find-symbol "BRANCO-RESPONDE" jog1))
	   (symbol-function (find-symbol "PRETO-INICIA" jog2))
	   (symbol-function (find-symbol "PRETO-RESPONDE" jog2))
	   )
  )

;;;============================================================
;;; Modulo gerenciador de jogo

(setf *columns* '(:a :b :c :d :e :f :g))
(setf *tabu* (make-array 42))

;;; Rotinas para executar uma partida

;;;--------------------------------------------------
;;; A funcao partida recebe quatro funcoes (branco-inicia do primeiro jogador,
;;; branco-responde do primeiro jogador, preto-inicia  do segundo jogador, 
;;; preto-responde  do segundo jogador) e executa uma partida entre os dois.
;;; O valor retornado e' um dos seguintes:
;;;    (desclassificado branco) --->  se o primeiro jogador fez invalida
;;;    (desclassificado preto ) --->  se o segundo  jogador fez invalida
;;;    (vitoria branco)         --->  se o primeiro jogador ganhou
;;;    (vitoria preto )         --->  se o segundo  jogador ganhou
;;;    (empate)                 --->  se o jogo empatou

(defun partida (branco-inicia branco-responde preto-inicia preto-responde)
  "Executa partida entre dois jogadores"

  (let
      ((vez 'branco)			; vez pode ser 'branco ou 'preto
					; valor inicial: 'branco
       
       (primeiro-lance-branco t)	; primeiro-lance indica se e' o
       (primeiro-lance-preto  t)	; primeiro lance de 'branco e 'preto
					; valor inicial: ambos t

       (lance 1)			; valor numerico do lance
                                        ; cada jogada e' um lance
					; valor incial: 1
       
       jogada				; jogada passada de um jogador
					; a outro
					; valor inicial: irrelevante
       )

    (nila-tabu)				; enche tabuleiro de NILs
    
    (loop				; repita ate' algum return

     ;; chame a funcao apropriada
     ;; passe jogada e receba jogada
     (setf jogada
           (if (equal vez 'branco)
             ;; vez do  Branco
             (if primeiro-lance-branco
                (funcall branco-inicia)
                (funcall branco-responde jogada)
                )
             ;; vez do  Preto
             (if primeiro-lance-preto
                (funcall preto-inicia jogada)
                (funcall preto-responde jogada)
                )
             )
           )

     ;; nunca mais sera' o primeiro-lance
     ;; do jogador de quem e' a vez.  07/09/97
     (if (equal vez 'branco)
       (setf primeiro-lance-branco nil)
       (setf primeiro-lance-preto nil)
       )

     ;; imprime o numero da jogada (lance) e a jogada; atualiza lance
     (if (equal vez 'branco)
	 (format t "\n~s. ~s" (/ (+ 1 lance) 2) jogada)
       (format t " , ~s" jogada)
       )
     (incf lance)

     ;; muda formato para (x y), x em [0..6], y em [0..5]
     (unless (setf casa (formato-interno jogada))
       (return (list 'desclassificado vez)))
     
     ;; verifica se invalida
     (unless (valida casa *tabu*)
       (return (list 'desclassificado vez)))

     ;; modifica posicao
     (marca *tabu* casa vez)

     ;; ve se o cara da vez ganhou com esta jogada
     (when (ganhou vez casa *tabu*)
	 (return (list 'vitoria vez)))

     ;; agora checa empate
     (when (empatou lance)
       (return '(empate)))
     
     ;; atualiza para proxima iteracao
     (setf vez (if (equal vez 'branco) 'preto 'branco))
    )
  )
)

;;;------------------------------------------------------------
;;; Nila-tabu: coloca nil em todas as posicoes

(defun nila-tabu ()
  (dotimes
   (x 7)
   (dotimes
    (y 6)
     (setf (aref *tabu* (+ (* 6 x) y)) nil) ) ) )

;;;------------------------------------------------------------
;;; Para propositos de debug apenas: remove os pacotes ja'
;;; carregados

(defun tira-tudo (jogadores)
  (dolist (jogador jogadores)
	  (delete-package jogador)
	  )
  )

;;;------------------------------------------------------------
;;; Funcao carrega: carrega o pacote de um jogador

(defun carrega (jogador)
  (load (string-downcase (symbol-name jogador)))
  )

;;;--------------------------------------------------
;;; Parte mais especifica do jogo de  OPOSICAO .
;;;
;;;---------------------------------------------------------
;;; Modifica formato de JOGADA; retorna novo
;;; formato descrito abaixo; se nao conseguir,
;;; retorna NIL
;;;
;;; O argumento JOGADA tem que ser uma lista de
;;; dois elementos.
;;; Primeiro elemento: :a,:b,:c,:d,:e,:f,:g --> 0,1,2,3,4,5,6
;;; Segundo elemento: 1,2,3,4,5,6 --> 0,1,2,3,4,5

(defun formato-interno (jogada)
  "Retorna JOGADA no formato interno"
  (and
    (listp jogada)
    (= 2 (length jogada))
    (let ((x (position (first jogada) *columns*))
	  (y (- (second jogada) 1))
	  )
      ;; sacanagem: retorna a lista se ambos numericos
      (and (numberp x) (numberp y) (list x y))
      )
    )
  )
    
;;;---------------------------------------------------------
;;; Verifica se JOGADA e' valida para um JOGADOR
;;;   numa determinada POSICAO
;;; Formato da JOGADA: (x y)
;;;
;;; O JOGADOR pode ser:  branco  ou  preto
;;; Formato da POSICAO:
;;;     e' uma array 7 x 6 que contem em cada
;;;     posicao um dos valores:
;;;     BRANCO
;;;     PRETO
;;;     NIL
;;;
;;; Jogada e' valida se:
;;; 1.   elementos sao numericos e esta' dentro do tabuleiro
;;; 2.   casa de mesmo x e y anterior ocupada (se y > 0)
;;; 3.   casa (x y) livre

(defun valida (casa posicao)
  "Verifica de CASA e' valida na POSICAO"
  (and
   (dentro casa)
   (or
    (<= (second casa) 0)
    (ocupada (list (first casa) (- (second casa) 1)) posicao)
    )
   (livre casa posicao)
   )
  )

;;;-----------------------------------------------
;;; Auxiliares de validacao de jogada
;;;-----------------------------------------------

;;;-----------------------------------------------
;;; Validacao de casa: funcao que verifica se uma
;;; casa e' valida.
;;; Formato da casa:  (x y), x em [0..6], y em [0..5]

(defun dentro (casa)
  "Verifica se CASA esta' dentro do tabuleiro"
  (let ((x (first casa) )
	(y (second casa)))
    (and
     (<= 0 x)
     (>= 6 x)
     (<= 0 y)
     (>= 5 y)
     )
    )
  )

;;;------------------------------------------------------------
;;; Ocupado e livre: sao uma a oposta da outra.  Verificam se
;;; uma certa poiscao dentro do tabuleiro esta' ocupada ou livre.
;;; As posicoes tem a mesma sintaxe das jogadas.

(defun ocupada (casa posicao)
  (aref posicao (lineariza casa))
  )

(defun livre (casa posicao)
  (not (ocupada casa posicao)) )

;;;--------------------------------------------------
;;; Modifica a posicao dada a casa onde foi a jogada
;;;

(defun marca (tabu casa jogador)
  "Marca no TABULEIRO uma CASA ocupada pelo JOGADOR"
  (setf (aref
	 tabu
	 (lineariza casa)
	 )
	jogador) )

;;;------------------------------------------------------
;;; Verificacao de posicao ganhadora
;;; 

(defun ganhou (jogador casa posicao)
  "Verifica se o JOGADOR jogando em CASA
   criou uma POSICAO vitoriosa."
  (or
   (<= 4 (qtas-consecutivas jogador casa posicao '(1  0))) 
   (<= 4 (qtas-consecutivas jogador casa posicao '(0  1))) 
   (<= 4 (qtas-consecutivas jogador casa posicao '(1  1))) 
   (<= 4 (qtas-consecutivas jogador casa posicao '(1 -1)))
   )
  )

(defun qtas-consecutivas (jogador casa posicao vetor)
  "Retorna o numero de casas ocupadas pelo
   JOGADOR a partir de CASA na POSICAO na direcao
   do VETOR.  Supoe-se que a CASA ja' esteja ocupada
   pelo JOGADOR."
  (+ 1
     (qtas-direto jogador
		  (seguinte casa vetor)
		  posicao
		  vetor)
     (qtas-direto jogador
		  (seguinte casa (menos vetor))
		  posicao
		  (menos vetor))
     )
  )

(defun menos (vetor)
  "Retorna o oposto de um VETOR dado."
  (list (- (first vetor)) (- (second vetor)))
  )

(defun seguinte (casa vetor)
  "Retorna a casa seguinte `a CASA na
   direcao do VETOR."
  (list (+ (first  casa) (first  vetor))
	(+ (second casa) (second vetor))
	)
  )

(defun qtas-direto (jogador casa posicao vetor)
  "Retorna quantas casas ocupadas pelo JOGADOR
   existem a partir de CASA na POSICAO na
   direcao do VETOR.  Nao supoe que a CASA
   esteja ocupada pelo JOGADOR, men mesmo que
   esteja dentro do tabuleiro."
  (cond
   ( (not (dentro casa))
     0 )
   ( (equal jogador (apply #'aref *tabu* (list (lineariza casa))))
     (+ 1 (qtas-direto jogador (seguinte casa vetor) posicao vetor)) )
   ( t
     0 )
   )
  )

;;;------------------------------------------------------------
;;; Transforma casa (x y) em um numero: 7x+y

(defun lineariza (casa)
  "Retorna indice linear da CASA"
  (+ (* 6 (first casa)) (second casa))
  )

;;;------------------------------------------------------------
;;; Funcao que verifica se est'a tudo preenchido

(defun empatou (lance)
  (> lance 42)
  )