;;;------------------------------------------------------------
;;; Gerenciador de campeonato
;;; Modificado em 28/08/03 para jogo TANBO.
;;; Versao de Mon Sep  8 14:48:49 EST 2003
;;;
;;; Funcao principal: chama-se campeonato
;;;
;;; Recebe uma lista de nomes de pacotes e promove um campeonato entre
;;; os ditos cujos.  Cada pacote e devera conter as seguintes funcoes:
;;;
;;;   preto-inicia()
;;;   preto-responde( jogada )
;;;   branco-inicia( jogada )
;;;   branco-responde( jogada )
;;;  
;;; Cada jogo e' iniciado com uma chamada da funcao "preto-inicia" do
;;; pacote do jogador preto, seguida por uma chamada da funcao
;;; "branco-inicia" do pacote do jogador branco. A partir dai, as
;;; funcoes "preto responde" e "branco-responde" sao chamadas
;;; alternadamente ate' que um jogados venca. O parametro jogada
;;; corresponde a ultima jogada feita pelo adversario.
;;;
;;; 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  Preto  quanto como
;;; Branco .  O  Preto  sempre comeca.

(defvar *placar* nil)
(defvar *tabuleiro* nil)
;; O tabuleiro e composto por um array e duas listas: 
;;   Array: um tabuleiro 9X9 com caracter "P" onde houver 
;;          uma peça preta,um caracter "B" onde houver uma peça branca
;;          e um caracter "L" (Livre) onde nao houver peça.
;;  Lista1: raizes do jogador preto.
;;  lista2: raizes do jogador branco.
;;
;; As listas, por sua vez, sao compostas por tres listas:
;; Lista 1: A posicao de inicio da raiz
;; Lista 2: As posiçoes livres da raiz.
;;          (Se esta lista e' vazia, a raiz morre)
;; Lista 3: As posicoes ocupadas pela raiz.

(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)
			  (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) 'preto)
	  ;; Preto , 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) 'branco)
	  ;;  Branco, ou seja, jog2, ganhou
	  ;; numero de vitorias e' o segundo da lista
	  (incf (second (assoc jog2 placar)))
	  ;; numero de derrotas e' o terceiro da lista
	  (incf (third (assoc jog1 placar)))
	  )
    )
   ;; quando um e' desclassificado, o outro ganha ponto
   ((equal (car resultado) 'desclassificado)
    (when (equal (second resultado) 'preto)
	  ;;  Preto , 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) 'branco)
	  ;;  Branco, 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 "PRETO-INICIA" jog1))
	   (symbol-function (find-symbol "PRETO-RESPONDE" jog1))
	   (symbol-function (find-symbol "BRANCO-INICIA" jog2))
	   (symbol-function (find-symbol "BRANCO-RESPONDE" jog2))
	   )
  )

;;; Modulo gerenciador de jogo
;;; Rotinas para executar uma partida

(defun novo-tabuleiro ()
  ;; Inicializa um tabuleiro 9X9
  (setf tabuleiro (make-array '(9 9) :initial-element 'l))
  ;; Posiciona as raizes:
  (setf (aref tabuleiro 1 1) 'p) ;; b2 para preto
  (setf (aref tabuleiro 7 7) 'p) ;; h8 para preto
  (setf (aref tabuleiro 1 7) 'b) ;; b8 para branco
  (setf (aref tabuleiro 7 1) 'b) ;; h2 para branco
  ;; O tabuleiro e' uma lista composta por tres elementos:
  (list 
   ;; - Um tabuleiro
   tabuleiro 
   ;; - As raizes do jogador preto:
   '(
     ( (:B 2) ((:A 2)(:B 1)(:B 3)(:C 2)) ((:B 2)) ) 
     ( (:H 8) ((:G 8)(:H 7)(:H 9)(:J 8)) ((:H 8)) )
     )
   ;; - As raizes do jogador branco:
   '(
     ( (:B 8) ((:A 8)(:B 7)(:B 9)(:C 8)) ((:B 8)) )
     ( (:H 2) ((:G 2)(:H 1)(:H 3)(:J 2)) ((:H 2)) )
     )
  )
)

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

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

  ;; Inicializa o tabuleiro tabuleiro
  (setf *tabuleiro* (novo-tabuleiro))


  (let ((vez 'preto)			; vez pode ser 'preto ou 'branco
					; valor inicial: 'preto
	
	(primeiro-lance-preto t)	; primeiro-lance indica se e' o
	(primeiro-lance-branco t)	; primeiro lance de 'preto e 'branco
					; valor inicial: ambos t
			
	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 'preto)
             ;; vez do  Preto
             (if primeiro-lance-preto
                (funcall preto-inicia)
                (funcall preto-responde jogada)
                )
             ;; vez do  Branco
             (if primeiro-lance-branco
                (funcall branco-inicia jogada)
                (funcall branco-responde jogada)
                )
             )
           )

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

     ;; imprime o jogador e a jogada
     (print (cons vez jogada))
     
     ;; verifica se invalida
     (unless (valida jogada vez)
	     (return (list 'desclassificado vez)))

     ;;retira raízes limitadas
     (setf *tabuleiro* (remove-raizes jogada vez))

     ;; ve se o cara da vez ganhou ou perdeu com esta jogada .Um
     ;; jogador pode limitar a propria raiz, logo, o lance de um
     ;; jogador pode fazer com que ele mesmo perca, por isso, e
     ;; preciso verificar sempre a vitoria tanto do branco quanto do
     ;; preto.
     (when (preto-ganhou)
       (return '(vitoria preto)))
     (when (branco-ganhou)
       (return '(vitoria branco)))

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

;;;------------------------------------------------------------
;;; 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  BRANCOS E PRETO .
;;;
;;;---------------------------------------------------------
;;; Verifica se JOGADA e' valida para um JOGADOR
;;;   numa determinada POSICAO
;;; Formato da JOGADA: (c l)
;;; onde l=linha, c=coluna
;;; O JOGADOR pode ser:  preto  ou  branco
;;;
;;; Jogada e' valida se atende os seguintes criterios:
;;; 1.   Consiste numa lista de dois elementos
;;; 2.   O primeiro elemento e' um atomo.
;;; 3.   O segundo elemento e' um numero.
;;; 4.   (l c) e' uma casa valida
;;; 5.   (l c) e' uma posicao livre para uma das raízes do 
;;;      jogador.

(defun valida (jogada jogador)
  "Verifica de JOGADA do JOGADOR e' valida
   na POSICAO"
  (and
    (listp jogada)                ;; Criterio 1
    (= 2 (length jogada))         ;; Criterio 1
    (atom (first jogada))         ;; Criterio 2
    (numberp (second jogada))     ;; Criterio 3
    (dentro-do-tabuleiro jogada)  ;; Criterio 4
    (lance-ok jogador jogada)     ;; Criterio 5
    )
  )

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

;;;-----------------------------------------------
;;; Validacao de casa: funcao que verifica se uma
;;; casa e' valida.
;;; Formato da casa:  (l c)
;;; Casa e' valida se c for um numero entre 1 e 9 e se l for um
;;; caracter pertencente a (a b c d e f g h j) e
(defun dentro-do-tabuleiro (pos)
;; retorna true se pos situa-se dentro do tabuleiro.
  (let ((c (first pos))
	(l (second pos)))
    (and 
      (> l 0)
      (< l 10)
      (member c '(:A :B :C :D :E :F :G :H :J))
      t
    )
  )
)

(defun cartesiano (posicao)
;; devolve a posicao em coordenadas cartesianas. (A 1) corresponde a
;; (0 0), sendo que a entrada e' na forma (c l) e a saida na forma 
;; (l c), onde l=linha e c=coluna.
  (list (- (second posicao) 1)
	(position (first posicao) '(:A :B :C :D :E :F :G :H :J)))
  )

(defun cor (posicao)
  (setf pos (cartesiano posicao))
  (cond
   ((equal (aref (first *tabuleiro*) (first pos) (second pos)) 'L)
    'livre)
   ((equal (aref (first *tabuleiro*) (first pos) (second pos)) 'P)
    'preto)
   ((equal (aref (first *tabuleiro*) (first pos) (second pos)) 'B)
    'branco)
   )
)

(defun anterior (simbolo)
  (if (member simbolo '(:A :B :C :D :E :F :G :H :J))
      (cadr (member simbolo '(:J :H :G :F :E :D :C :B :A NIL)))
    (if (member simbolo '(1 2 3 4 5 6 7 8 9))
	(cadr (member simbolo '(9 8 7 6 5 4 3 2 1 NIL)))
      nil)))
    
(defun posterior (simbolo)
  (if (member simbolo '(:A :B :C :D :E :F :G :H :J))
      (cadr (member simbolo '(:A :B :C :D :E :F :G :H :J NIL)))
    (if (member simbolo '(1 2 3 4 5 6 7 8 9))
	(cadr (member simbolo '(1 2 3 4 5 6 7 8 9 NIL)))
      nil)))

(defun vizinhos (posicao)
;;Devolve as posicoes vizinhas dentro do tabuleiro na forma de uma
;;lista de pares (posicao cor)
  (let ((c (first posicao))
	(l (second posicao)))
    (setf pre-list
	  (list 
	   (list (anterior c)  l)
	   (list (posterior c) l)
	   (list  c (anterior l))
	   (list  c (posterior l))))
    (setf ans nil)
    (dolist (item pre-list ans)
      (if (and 
	   (not (null (first  item)))
	   (not (null (second item))))
	  (setf ans (cons (list item (cor item)) ans))
	)
	   
    ans))
  )
    
(defun vizinhos-sem-cor (posicao)
;;Devolve as posicoes vizinhas dentro do tabuleiro sem as cores.
  (let ((c (first posicao))
	(l (second posicao)))
    (setf pre-list
	  (list 
	   (list (anterior c)  l)
	   (list (posterior c) l)
	   (list  c (anterior l))
	   (list  c (posterior l))))
    (setf ans nil)
    (dolist (item pre-list ans)
      (if (and 
	   (not (null (first  item)))
	   (not (null (second item))))
	  (setf ans (cons  item  ans))
	)
    ans))
  )
    
(defun lance-ok (jogador jogada)
  ;; Verifica se um lancee segue as regras do jogo.
  (let ((raizes (if (equal jogador 'preto)
		    (second *tabuleiro*)
		  (third *tabuleiro*)))
	(raizes-adv (if (equal jogador 'preto)
			(third *tabuleiro*)
		      (second *tabuleiro*)))
	(adversario (if (equal jogador 'preto) 
			'branco 'preto)))
	(if (posicao-valida jogador jogada)
	    ;; Somente se a posicao da jogada for valida (i.e., numa
	    ;; casa livre com apenas um vizinho da mesma cor...),
	    ;; marca a posicao no tabuleiro e altera as listas de
	    ;; raizes.
	    (progn
	      (setf *tabuleiro* (list (posiciona jogador jogada 
						 (first *tabuleiro*)) 
				      (second *tabuleiro*) 
				      (third *tabuleiro*))) 
	      (setf raizes     (insere jogador jogada raizes))
	      (setf raizes-adv (retira adversario jogada raizes-adv))
	      (if (equal jogador 'preto)
		  (setf *tabuleiro* (list (first *tabuleiro*)
					  raizes
					  raizes-adv))
		(setf *tabuleiro* (list (first *tabuleiro*)
					raizes-adv
					raizes)))
	      t
	      )
	  ;; Se a posicao nao for valida, retorna nil...
	  nil
	  )
	)
  )

(defun remove-raizes (jogada jogador)
  ;; devolve um novo tabuleiro excluindo raizes limitadas, segundo as
  ;; regras do jogo:
  ;;   - Primeiro testa se a raiz extendida foi limitada e a retira em
  ;;     caso afirmativo.  
  ;;   - Se a raiz extendida nao foi eliminada,
  ;;     testa todas as outras e remove as que tenham sided limitadas.
  (let ((raizes (if (equal jogador 'preto)
		     (second *tabuleiro*)
		  (third *tabuleiro*)))
	(raizes-adv (if (equal jogador 'preto)
		     (third *tabuleiro*)
		  (second *tabuleiro*)))
	(adversario (if (equal jogador 'preto) 'branco 'preto))
	(raizes-aux nil))
    (let ((raiz-aumentada (pega-raiz jogada raizes)))
      (if (null (second raiz-aumentada))
	  (progn
	    (remove-raiz raiz-aumentada)
	    (setf raizes (set-difference raizes 
					 (list raiz-aumentada)
					 :test #'equal))
	    )
	(progn 
	  (dolist (raiz raizes raizes-aux)
	    (if (null (second raiz))
		(remove-raiz raiz)
	      (setf raizes-aux (cons raiz raizes-aux))
	      )
	    )
	  (setf raizes raizes-aux)
	  (setf raizes-aux nil)
	  (dolist (raiz raizes-adv raizes-aux)
	    (if (null (second raiz))
		(remove-raiz raiz)
	      (setf raizes-aux (cons raiz raizes-aux))
	      )
	    )
	  (setf raizes-adv raizes-aux)
	  )
	)
      (setf raizes (reve-posicoes-livres raizes jogador))
      (setf raizes-adv (reve-posicoes-livres raizes-adv adversario))
      (if (equal jogador 'preto)
	  (list (first *tabuleiro*) raizes raizes-adv)
	(list (first *tabuleiro*) raizes-adv raizes)
	)
      )
    )
  )

(defun pega-raiz (jogada raizes)
;; Devolve a raiz a qual a ultima jogada foi ligada.
  (let ((ans nil))
    (dolist (raiz raizes ans)
      (if (member jogada (third raiz) :test #'equal )
	  (setf ans raiz)
	)
      )
    )
  )

(defun remove-raiz (raiz)
;; Elimina as peças de uma raiz do tabuleiro.
  (dolist (posicao (third raiz) t)
    (libera posicao))
  )

(defun reve-posicoes-livres (raizes jogador)
;; reconstroi cada lista de posicoes livres do nada.
;; (Simplesmente ignora a antiga lista e constrroi uma nova)
;; Deve ser chamada para cada raiz depois da remoção de
;; alguma raiz.
  (let ((raizes-aux nil)
	(livres-aux nil))
    (dolist (raiz raizes raizes-aux)
      (setf livres-aux nil)
      (dolist (posicao (third raiz) t)
	(setf livres-aux (union (vizinhos-validos jogador posicao)
				livres-aux 
				:test #'equal))
	)
      (setf raizes-aux (cons (list (first raiz)
				   livres-aux
				   (third raiz))
			     raizes-aux))
      )
    )
  )

(defun posiciona (jogador jogada tabuleiro)
;; Marca a a posiçao da jogada com o simbolo do jogador.
;; (Atualiza apenas o array!)
  (let ((coord (cartesiano jogada))
	(simbolo (if (equal jogador 'preto) 'p 'b)))
    (setf (aref tabuleiro (first coord) (second coord)) simbolo)
    tabuleiro
    )
  )
	  
(defun libera (posicao)
;; Libera uma posicao no tabuleiro
  (let ((coord (cartesiano posicao)))
    (setf (aref (first *tabuleiro*) (first coord) (second coord)) 'L)
    )
  )

(defun vizinhos-validos (jogador jogada)
;; retorna os vizinhos de uma jogada que ainda sao livres para o jogador
  (let ((ans nil))
    (dolist (item (vizinhos jogada) ans)
      (if (and
	   (equal (second item) 'livre)
	   (posicao-valida jogador (first item)))
	  (setf ans (cons (first item) ans )))
      )
    )
  )

(defun atualiza-livres (jogador jogada raiz)
;; verifica se a nova jogada inseriu ou removeu posicoes livres
;; (so pode ser usada na raiz conectada a nova posicao.)
  (union 
   (vizinhos-validos jogador jogada)
   (set-difference (second raiz) 
		   (cons jogada (vizinhos-sem-cor jogada))
		   :test #'equal)
   :test #'equal)
  )

(defun reavalia-livres (jogador jogada raiz)
;; elimina posicoes que se tornaram invalidas.
;; (usada somente para as raizes do jogador e nao para as do adversario)
  (set-difference (second raiz) 
		  (cons jogada (vizinhos-sem-cor  jogada))
		  :test #'equal)
  )

(defun insere (jogador jogada raizes)
;; insere a posicao da jogada numa das raizes do jogador.
  (let ((ans nil))
    (dolist (raiz raizes ans)
      (if
	(and
	 (member jogada (second raiz) :test #'equal)
	 (not (member jogada (third raiz) :test #'equal)))
	  (setf ans (cons (list (first raiz)
				(atualiza-livres jogador jogada raiz)
				(cons jogada (third raiz)))
			  ans))
	(setf ans (cons (list
			 (first raiz)
			 (reavalia-livres jogador jogada raiz)
			 (third raiz))
			ans)
	      )
	)
      )
    )
  )

(defun posicao-valida (jogador jogada)
;; Retorna T se a posicao e' valida. Ou seja:
;; - Se a posicao esta livre.
;; - Se a posicao garante que a peca inserida estara conectada
;;   a apenas uma peca de uma das raizes do jogador.
  (and 
   (equal (cor jogada) 'LIVRE)
   (= 1 (conta-vizinhos-iguais jogador jogada))
   )
  ) 

(defun conta-vizinhos-iguais (jogador jogada)
;; conta quantas posiçoes vizinhas sao ocupadas por pecas do
;; jogador emquestao.
  (let ((vizinhos (vizinhos jogada))
	(count 0))
    (dolist (item vizinhos count)
      (if (equal (second item) jogador)
	  (setf count (+ 1 count))
	)
      )
    )
  )

(defun retira (jogador jogada raizes)
;; retira a posicao da jogada das posicoes livres das raizes do
;; adversario
  (let ((ans nil))
    (dolist (raiz raizes ans)
      (setf ans (cons (list (first raiz)
			    (set-difference (second raiz) 
					    (list jogada)
					    :test #'equal)
			    (third raiz))
		      ans))
      )
    )
  )


;;;------------------------------------------------------
;;; Verificacao de posicao ganhadora
;;;
;;; Para ambos significa que o adversario nao possui mais raizes
;;; (Nunca ha' empate.)

(defun preto-ganhou ()
  "Verifica se branco nao tem raizes"
    (null (third *tabuleiro*))
  )

(defun branco-ganhou ()
  "Verifica preto nao tem mais raizes "
  (null (second *tabuleiro*))
  )


;;; Só pra ajudar a testar:
;;; Iniciar o tabuleiro: (setf *tabuleiro* (novo-tabuleiro))
;;; Para jogar: (m a 2 p) indica movimento na casa a2 do jogador preto.
                    ;;;  Jogador branco e' "o" e nao "b", pois b ja' e'
                    ;;;  uma das colunas do tabuleiro.
(setf a ':a b ':b c ':c d ':d e ':e f ':f g ':g h ':h j ':j p 'preto o 'branco)
(defun m (c l j)
  (valida (list c l)
	  j)
  (setf *tabuleiro* (remove-raizes (list c l)
		 j))
  (when (preto-ganhou)
    (return '(vitoria preto)))
  (when (branco-ganhou)
    (return '(vitoria branco)))
  *tabuleiro*
  )