;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;
;;;$Header: /ct/ctlisp/gcolor.l,v 1.2 83/12/28 14:10:26 mark Exp $
;;; 
;;;$Log:	/ct/ctlisp/gcolor.l,v $
;;;Revision 1.2  83/12/28  14:10:26  mark
;;;Added conditionalization for Franz arrays, and made
;;;check_consistency return t or nil as appropriate, rather
;;;than just printing warning messages as before.
;;;
;;;Revision 1.1  83/12/28  08:48:59  mark
;;;Initial revision
;;;
;;; 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                      GCOLOR                                      ;;;
;;; Lee Blaine                                 December, 1983        ;;;
;;;                                                                  ;;;
;;;       This file contains an algorithm for coloring a graph.      ;;;
;;;                                                                  ;;;
;;;                                                                  ;;;
;;; This file is part of a proprietary software project.  Source     ;;;
;;; code and documentation describing implementation details are     ;;;
;;; available on a confidential, non-disclosure basis only.  These   ;;;
;;; materials, including this file in particular, are trade secrets  ;;;
;;; of Computer * Thought Corporation.                               ;;;
;;;                                                                  ;;;
;;; (c) Copyright 1982 and 1983,  Computer * Thought Corporation.    ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;; Reference materials:                                             ;;;
;;;   Foderaro and Sklower, The FRANZ LISP Manual, September 1981.   ;;;
;;;   Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981.   ;;;
;;;   Charniak et al., 1980.  Artificial Intelligence Programming.   ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;;   AJPO, Feb 1983.  ANSI/MIL-STD-1815A  Ada Reference Manual.     ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;                                                                  ;;;
;;;	        ASSUMES CT_LOAD AND SUITABLE FILEMAP                 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(eval-when (compile load eval) (ct_load 'charmac)) ;CT char set extensions.

(eval-when (compile load eval) (ct_load 'aip))	  ;AIP macros pkg. 

(eval-when (compile load eval) (ct_load 'compat)) ;Franz/LM compat pkg.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;               GRAPH  coloring Algorithm
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



  #| The function color_graph should be called with a graph of the form
        ((node_name1 (associated nodes))
         (node_name2 (associated nodes)....))
     and will return a list of pairs (node_name  number) where the
     number is the associated color for that node_name.
     IMPORTANT:  All graphs should first be run through the consistency check
     function, check_consistency, before being run through the color_graph
     algorithm to ensure that the graph has the correct format.
     Examples of graphs can be found in /mnt/lee/gcolor.tst.   |#


	;;;;;;;;;;;
(defun  color_graph  (graph)
	;;;;;;;;;;;
  ;;;Returns a coloring for graph, i.e., a list of pairs (node_name number) 
  ;;;where number is the associated color for that node_name.
  ;;;The graph is first put into a canonical form suitable for deletion
  ;;;operations. A special ordered representation of the graph is then
  ;;;constructed, and finally, colors are chosen by stepping
  ;;;through the ordered representations.
  (color_nodes  (order_nodes  (canonical_form  graph))))




	;;;;;;;;;;;
(defun  order_nodes (graph) 
	;;;;;;;;;;;
  (let ((node_ordering  nil))
    (loop  while  (not (null (cdr graph)))
	   for   min_node   =  (select_min_node  graph)
	   do   (progn
		  (ct_push   min_node  node_ordering)
		  (setq      graph     (remove_node  min_node  graph)))
	   finally  (return  node_ordering))))




	 ;;;;;;;;;;;
(defun   color_nodes  (node_ordering)
         ;;;;;;;;;;;
  
  (init_colors)
  (init_coloring)
  
  (loop  for  node  in  node_ordering
	 do   (select_color_for  node))

  (return_coloring))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;               GRAPH  and  NODE  Data Types
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar  *max_degree*)   ;max degree of original graph--internal use

	 ;;;;;;;;;;;;;;;;;;;
(defun   max_degree_of_graph  ()  *max_degree*)
	 ;;;;;;;;;;;;;;;;;;;

  
	;;;;;;;;;;;;;;
(defun  canonical_form  (old_graph)
	;;;;;;;;;;;;;;
  (setq  *max_degree*  0)
  (cons  *max_degree*
	 (mapcar  #'(lambda  (old_node)  (create_node  old_node))
		  old_graph)))


	;;;;;;;;;;;
(defun  create_node (old_node)
	;;;;;;;;;;;
  (let* ((new_adjacents  (#+lispm copylist
			  #+franz copy      (second old_node)))
	 (degree         (length new_adjacents)))
    (ct_if  (>  degree  *max_degree*)
	    (setq  *max_degree*  degree))
  `(,(first old_node) ,(cons degree  new_adjacents))))

	;;;;;;;;;
(defun  node_name      (node)  (first  node))
	;;;;;;;;;

	;;;;;;;;;;;
(defun  node_degree    (node)  (first (second node)))
	;;;;;;;;;;;

	;;;;;;;;;;;;;;
(defun  node_adjacents (node)  (cdr (second node)))
	;;;;;;;;;;;;;;





	;;;;;;;;;;;
(defun  is_adjacent (node1 node2)
	;;;;;;;;;;;
;;; an asymmetric version
 (memq  (node_name node1) (node_adjacents node2)))

	;;;;;;;;;;;;;;;;
(defun  remove_adjacency  (node1 node2)
	;;;;;;;;;;;;;;;;
  ;;; an asymmetric version
  (let ((tail (second node2))
	(node1_name (node_name node1)))
    (loop  while (cdr tail)
	   do (cond  ((eq  node1_name (cadr tail))
		      (rplacd tail (cddr tail))
		      (return))
		     (t
		      (setq tail (cdr tail)))))
    (rplaca (second node2) (1- (node_degree node2)))))




	;;;;;;;;;;;;;;;
(defun  select_min_node  (graph)
        ;;;;;;;;;;;;;;;
  (let* ((min_degree  1000)
	 (min_node     nil))
    
    (loop  for  node  in  (cdr graph)
	   do  (ct_if  (< (node_degree node)  min_degree)
		       (progn
			 (setq  min_degree (node_degree node))
			 (setq  min_node   node)))
	   finally  (return  min_node))))




	;;;;;;;;;;;
(defun  remove_node  (min_node  graph)
        ;;;;;;;;;;;
  (let  ((tail  graph))
    (loop  while  (cdr tail)
	   for    node  = (cadr tail)
	   do    (cond  ((eq  min_node  node)
			 (setq  tail  (rplacd tail (cddr tail))))
			((is_adjacent  min_node  node)
			 (remove_adjacency  min_node node)
			 (setq tail (cdr tail)))
			(t
			 (setq tail (cdr tail)))))
    graph))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                     Colors  Data Type
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defvar  *colors*)
(defvar  *max_color*)

	;;;;;;;;;;;
(defun  init_colors  ()  
	;;;;;;;;;;;
  (setq  *max_color*  (max_degree_of_graph))
  #+lispm (setq *colors* (make-array (1+ *max_color*)))
  #+franz (*array '*colors* t (1+ *max_color*)))

	;;;;;;;;;;;;
(defun  clear_colors  ()  
	;;;;;;;;;;;;
  (loop  for color  from 0 to *max_color*
	 do  #+lispm (aset  0  *colors*  color)
	     #+franz (store (*colors* color) 0)))

	;;;;;;;;;;;;;;;;
(defun  mark_colors_used (nnames)      ;;;interaction between 
	;;;;;;;;;;;;;;;;              ;;;colors and coloring
  (loop  for  nname in nnames
	 do   #+lispm (aset 1 *colors*  (get_color nname))
	      #+franz (store (*colors* (get_color nname)) 1)))

	;;;;;;;;;;;;;;
(defun  unused_color_p  (color)
	;;;;;;;;;;;;;;
  (zerop  #+lispm (aref *colors* color)
	  #+franz (*colors* color)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                     Coloring  Data Type
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar  *coloring*)


	;;;;;;;;;;;;;
(defun  init_coloring  ()  
	;;;;;;;;;;;;;
  (setq  *coloring*  nil))


	 ;;;;;;;;;
(defun   get_color  (nname)
         ;;;;;;;;;
  (let  ((association  (assq nname  *coloring*)))
    (ct_if  (not (null association))
	    (second association)
	    (error  (format nil "Colorless Node:  ~A" nname)))))


	 ;;;;;;;;;
(defun   set_color  (nname color)
	 ;;;;;;;;;
  (ct_push  (list nname  color)  *coloring*))


	;;;;;;;;;;;;;;;
(defun  return_coloring  ()
	;;;;;;;;;;;;;;;
  *coloring*)


	;;;;;;;;;;;;;;;;
(defun  select_color_for  (node)
        ;;;;;;;;;;;;;;;;
  
  (let* ((adjacents    (node_adjacents node))
	 (node_colored  nil))
    
    (clear_colors)
    (mark_colors_used  adjacents)
    
    (loop  for color  from 0 to *max_color*
	   do  (ct_if  (unused_color_p color)
		       (progn
			 (set_color  (node_name node)  color)
			 (setq    node_colored t)
			 (return))))
    
    (ct_if  (null node_colored)
	    (error (format  nil  "Not enough colors")))))
    
 


       ;;;;;;;;;;;;;;;;;
(defun check_consistency (graph)
       ;;;;;;;;;;;;;;;;;
  ;;;The function check_consistency checks the validity of a graph
  ;;;representation.
  ;;;It checks that
  ;;;  (1) Adjacency is not reflexive.
  ;;;  (2) Adjacency is symmetric.
  ;;;The first condition is verified by checking
  ;;;that a node does not contain itself in its
  ;;;list of associated pairs.  The second condition is checked by
  ;;;ensuring that for each node name that is in a particular
  ;;;node's list, that same node appears in the other's node list
  (let ((error_found nil))
    (loop  for  (node_name node_list) in graph
	   if (memq node_name node_list)
	   do (progn
		(format t
			"~2&REFLEXIVITY ERROR:  Node name ~A appears in its adjacency list, ~A"
			node_name  node_list)
		(setq error_found t))
	   do (loop for node in node_list
		    for companion_node = (assoc node graph)
		    for companion_node_list = (cadr companion_node)
		    if (not (memq node_name companion_node_list))
		    do (progn
			 (format t
				 "~2&SYMMETRY ERROR:  Node name ~A appears in the adjacency
~8Xlist of ~A, but node name ~A isn't in the adjacency list of ~A"
				 node node_name  node_name node)
			 (setq error_found t))))
    (not error_found)))