;;;------------------------------------------------------------
;;; Gerenciador de campeonato
;;;
;;; Modificado em 11/0899 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 nderr ndesclass)
;;;   (jog2 nvit nderr ndesclass)
;;;    ...
;;;   (jogn nvit nderr ndesclass)
;;; )
;;;
;;; onde (jog1 jog2 ... jogn) e' a lista de entrada e nvit, nderr
;;; e ndesclass sao, respectivamente, o numero de vitorias,
;;; derrotas e desclassificacoes que cada jogador teve.  Nao ha'
;;; empates.
;;;
;;; 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.

(defvar *placar* nil)

(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)
	  (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)
  "Recebe JOG1, JOG2, o RESULTADO e o PLACAR.
   Tem como efeito colateral a modificacao do
   PLACAR para refletir o resultado."
  (cond
   ((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 terceiro da lista
	  (incf (third (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 (third (assoc jog1 placar)))
	  )
    )
   ;; quando um e' desclassificado, o outro ganha ponto
   ((equal (car resultado) 'desclassificado)
    (when (equal (second resultado) 'branco)
	  ;;  Branco , ou seja, jog1, foi desclassificado
	  ;; numero de desclassificacoes e' o quarto da lista
	  (incf (fourth (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 quarto da lista
	  (incf (fourth (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
;;; Rotinas para executar uma partida

(defvar *peao* '(1 8))			; posicao do peao
(defvar *limite* 60)			; limite de lances

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

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

  (let
      ((posicao '( (branco 8 1)		; posicao atual
		   (preto  1 7) ))	; valor inicial: posicao inicial

       (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
       )

    (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 lance, o jogador e a jogada; atualiza lance
     (format t "~s. ~s ~s" lance vez jogada)
     (terpri)
     (incf lance)
     
     ;; verifica se invalida
     (unless (valida jogada vez posicao)
	     (return (list 'desclassificado vez)))

     ;; modifica posicao
     (setf posicao (nova posicao jogada vez))

     ;; ve se o cara da vez ganhou com esta jogada
     (if (equal vez 'branco)
       (when (branco-ganhou posicao)
	   (return '(vitoria branco)))
       (when (preto-ganhou lance)
	   (return '(vitoria preto)))
       )

     ;; atualiza para proxima iteracao
     (setf vez (if (equal vez 'branco) 'preto 'branco))
    )
  )
)

;;;------------------------------------------------------------
;;; 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 .
;;;
;;;---------------------------------------------------------
;;; Verifica se JOGADA e' valida para um JOGADOR
;;;   numa determinada POSICAO
;;; Formato da JOGADA: (l c)
;;; onde l=linha, c=coluna
;;; O JOGADOR pode ser:  branco  ou  preto
;;; Formato da POSICAO:
;;;     ((branco bl  bc )
;;;      (preto  pl  pc ))
;;;
;;; Jogada e' valida se:
;;; 1.   formato esta' ok
;;; 2.   dentro do tabuleiro
;;; 3.   nao foi em cima do peao (so' para preto)
;;; 4.   andou 1 casa
;;; 5.   nao encostou no rei do outro

(defun valida (jogada jogador posicao)
  "Verifica de JOGADA do JOGADOR e' valida
   na POSICAO"
  (and
    (formato-ok jogada)
    (dentro jogada)
    (if (eq jogador 'preto)
	(not (em-cima-do-peao jogada))
      t)
    (dist-1 jogada
	    (if (eq jogador 'branco)
		(branco posicao)
	      (preto posicao)
	      )
	    )
    (not (dist-1 jogada
		 (if (eq jogador 'branco)
		     (preto posicao)
		   (branco posicao)
		   )
		 )
	 )
    )
  )

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

;;;-----------------------------------------------
;;; Validacao de casa: funcao que verifica se uma
;;; casa e' valida.
;;; Formato da casa:  (l c), com l e c inteiros

(defun formato-ok (casa)
  "Verifica se CASA esta' no formato certo"
  (and
    (listp casa)
    (= 2 (length casa))
    (integerp (first casa))
    (integerp (second casa))
    )
  )

(defun dentro (casa)
  "Verifica se linha e coluna de CASA
   estao dentro do intervalo [1..8]"
  (let ((linha (first casa))
	(coluna (second casa)))
    (and
     (<= 1 linha)
     (>= 8 linha)
     (<= 1 coluna)
     (>= 8 coluna)
     )
    )
  )

(defun em-cima-do-peao (casa)
  "Verifica se a JOGADA foi em cima do peao"
  (equal casa *peao*)
  )

;;;-------------------------------------------------
;;; Funcoes que extraem as casas ocupadas pelo
;;; Branco  e pelo  Preto  numa posicao.
;;;
;;; Formato da POSICAO:
;;;     ((branco bl  bc )
;;;      (preto  pl  pc ))
;;;

(defun branco (posicao)
  "Retorna a casa do  Branco  numa POSICAO"
  (cdar posicao)
  )

(defun preto (posicao)
  "Retorna a casa ocupada
   pelo  Preto  numa POSICAO"
  (cdadr posicao)
  )

;;;------------------------------------------
;;; Funcao que monta uma posicao a partir
;;; das casas do branco e preto

(defun monta-pos (br pr)
  (list
   (cons 'branco br)
   (cons 'preto  pr)
   )
  )

;;;------------------------------------------
;;; Verificacao de se uma dada casa e'
;;; alcancavel a partir de outra.
;;;
;;; Nota: e' olhado apenas o aspecto numerico,
;;; e nao se as jogadas esta' dentro ou fora do
;;; tabuleiro.

(defun dist-1 (casa1 casa2)
  "Verifica se a CASA1 pode ser alcancada
   em uma jogada a partir da CASA2"
  (let ((delta-l (- (first  casa1) (first  casa2)))
	(delta-c (- (second casa1) (second casa2)))
	)
    (= 1 (max (abs delta-l) (abs delta-c)))
    )
  )

;;;--------------------------------------------------
;;; Modifica a posicao dada a jogada efetuada
;;;

(defun nova (posicao jogada jogador)
  "Retorna a nova posicao resultante dada uma POSICAO
   e uma JOGADA efetuada nela pelo JOGADOR"
  (let ((pos-br (branco posicao))
	(pos-pr (preto  posicao))
	)
    (if (eq jogador 'branco)
	(monta-pos jogada pos-pr)
      (monta-pos pos-br jogada)
      )
    )
  )

;;;------------------------------------------------------
;;; Verificacao de posicao ganhadora
;;;
;;; Para o  Branco , isto significa: comeu o peao
;;;
;;; Para o  Preto  , isto significa: passou o limite
;;;
;;; Nunca ha' empate.

(defun branco-ganhou (posicao)
  "Verifica se a POSICAO reflete uma vitoria
   do  Branco ."
  (equal (branco posicao) *peao*)
  )

(defun preto-ganhou (lance)
  "Verifica se a POSICAO representa uma vitoria
   para o  Preto "
  (<= *limite* lance)
  )