;;; Graceful Labeling (Von Koch's conjecture)
;;; like a dfs, but assinging and verifying labels
;;; takes a tree in graph-expression form

(load "p80.lisp")
(load "p87.lisp")

(defun graceful-labeling (tree)
  "Returns a graceful label for TREE if one exists.  Node labels
   go from 1 to length of TREE; edge labels go from 1 to one less
   than length of TREE."
  (let* ((lista (ordered-edges tree))
	 (n (nnodes tree))
	 (seq (seq 1 n)))
    ;; quem tem label e' sempre o segundo do par
    (tenta-node (cadar lista) lista nil seq (seq 1 (1- n)) seq)
    )
  )

(defun tenta-node (node lista atrib node-labels edge-labels a-tentar)
  "Retorna uma atribuicao que completa ATRIB, com rotulos novos
   tirados de NODE-LABELS para nos, e EDGE-LABELS para arestas,
   sendo que o rotulo de NODE tem que ser um dos rotulos em A-TENTAR,
   caso exista; se nao existir, retorna NIL.
   LISTA eh a lista das arestas que falta rotular."
  (if (null a-tentar)
      nil
    (or (estende lista
		 (acons node (car a-tentar) atrib)
		 (remove (car a-tentar) node-labels)
		 edge-labels
		 )
	(tenta-node node lista atrib node-labels edge-labels (cdr a-tentar))
	)
    )
  )

(defun estende (lista atrib node-labels edge-labels)
  "Retorna uma atribuicao que completa ATRIB, com rotulos novos
   tirados de NODE-LABELS para nos, e EDGE-LABELS para arestas,
   se houver; caso contrário, retorna NIL.
   LISTA eh a lista das arestas que falta rotular."
  (if (null lista)
      atrib
    (tenta (car lista)
	   (cdr lista)
	   atrib
	   node-labels
	   edge-labels
	   node-labels)
    )
  )

(defun tenta (pair lista atrib node-labels edge-labels a-tentar)
  "Retorna uma atribuicao que completa ATRIB, com rotulos novos
   tirados de NODE-LABELS para nos, e EDGE-LABELS para arestas,
   sendo que PAIR eh a proxima aresta a tentar, e sabe-se que o
   segundo elemento de PAIR jah tem rotulo, enquanto que rotulo
   do primeiro elemento de PAIR tem que ser um dos rotulos em A-TENTAR.
   se nao existir tal atrbuicao, retorna NIL.
   LISTA eh a lista das arestas que falta rotular, alem de PAIR."
  (if (null a-tentar)
      nil
    (let* ((a (second pair))		; jah tem rotulo
	   (b (first pair))		; nao tem rotulo
	   (d (abs (- (car a-tentar) (cdr (assoc a atrib)))))
	   )
      (or (and (member d edge-labels)
	       (estende lista
			(acons b (car a-tentar) atrib)
			(remove (car a-tentar) node-labels)
			(remove d edge-labels)
			)
	       )
	  (tenta pair lista atrib node-labels edge-labels (cdr a-tentar))
	  )
      )
    )
  )

(defun ordered-edges (tree)
  "Retorna a lista de arestas da arvore TREE ordenadas de tal forma que,
   a partir da segunda aresta da lista, cada aresta tem exatamente um
   elemento que ja' apareceu antes, e exatamente um que nao apareceu antes.
   DFS pode ser usada para obter tal lista."
  (let ((dfs (dfs (ge-to-al tree) (caar tree))))
    (cdr
     (mapcar #'(lambda (x) (list x (my-first-neighbor x tree dfs)))
	     dfs))
    )
  )

(defun my-first-neighbor (node tree order)
  "Returns first TREE-neighbor of NODE in ORDER, or nil if none exists."
  (if (null order)
      nil
    (if (adjacent (car order) node tree)
	(car order)
      (my-first-neighbor node tree (cdr order))
      )
    )
  )

(defun adjacent (a b tree)
  (or (member (list a b) (second tree) :test #'equal)
      (member (list b a) (second tree) :test #'equal)
      )
  )

(defun nnodes (tree)
  (length (car tree))
  )

(defun seq (a b)
  (if (< b a)
      nil
    (cons a (seq (1+ a) b))
    )
  )