;;;; -*- mode:Scheme -*- ;;;;

;;;;;;;;;;;;;;;;;
;;; SOLVING CSP using the min-conflict heuristic.
;;;;;;;;;;;;;;;;;

(define *conflict-weight* #f)
(define *use-conflict-weight* #t)
(define *conflict-weight-increment* 0.1)

(define (min-conflict-hill-climb max-iterations initial-assignment)
  (let ((update-weight? #f)
	(prev-n-conflict-vars 0))
    ;; Do one iteration of the algorithm 
    (define (min-conflict-hill-climb-iteration i assignment)
      (if (= i max-iterations)
	  #f
	  (let* ((conflict-vars		; find all vars in conflict
		  (vars-in-conflict 
		   *variables* assignment *variables* update-weight?))
		 (n-conlict-vars (length conflict-vars)))
	    (if *verbose*
		(describe-conflicts n-conlict-vars conflict-vars assignment))
	    (if (null? conflict-vars)	; no conflicts
		assignment		; return
		(let* ((var (random-list-entry conflict-vars)) ; pick var
		       (value		; pick "best" value
			(select-min-conflict-value var assignment)))
		  (if *verbose*
		      (format #t "~a: Setting var ~a (~a) from ~a to ~a~%" 
			      i var (name-of var) (vector-ref assignment var) value))
		  (vector-set! assignment var value) ; set it
		  ;; we update weights when we are "stuck", that is,
		  ;; we are not reducing the number of variables
		  ;; involved in violations. we could also count
		  ;; actual arc violations instead.
		  (set! update-weight? 
			(and *use-conflict-weight* 
			     (= n-conlict-vars prev-n-conflict-vars)))
		  (set! prev-n-conflict-vars n-conlict-vars)
		  ;; go to next iteration.
		  (min-conflict-hill-climb-iteration
		   (+ 1 i) assignment))))))
    ;; initialize the weights if we are going to use them.
    (if *use-conflict-weight*
	(set! *conflict-weight* (make-vector (length *arcs*) 1)))
    ;; The rest of the code expects the answer to be a list.
    (let ((answer
	   (min-conflict-hill-climb-iteration 0 initial-assignment)))
      (if answer
	  (vector->list answer)
	  #f))))

;;; CHOOSING VALUES FOR A VARIABLE BASED ON THE NUMBER OF CONFLICTS (number
;;; of constraints arcs violated).

;;; Picks the value of the specified variable that violates the fewest
;;; constraints.  If there is a tie, it is settled randomly.

(define (select-min-conflict-value var assignment)
  (select-min-randomly 
   (map (lambda (value) 
	  (count-conflicts-for-var-value var value assignment #t #f))
	(domain-of var))
   (domain-of var)))

;;; Count the conflicts (number of violated constraint arcs) for a value of
;;; a variable.  Optionally, check only constraints involving only a subset
;;; of the other variables (relevant-vars).  If relevant-vars = #t, this
;;; means all other variables should be checked.

(define (count-conflicts-for-var-value 
	 var value assignment relevant-vars update-weight?)
  (+ (count-conflicts-for-var-value-aux 
      var value assignment relevant-vars (arcs-from var) update-weight?)
     (count-conflicts-for-var-value-aux
      var value assignment relevant-vars (arcs-into var) update-weight?)))

(define (count-conflicts-for-var-value-aux 
	 var value assignment relevant-vars arcs update-weight?)
  (let ((count 0))
    (for-each 
     (lambda (arc)
       (if (conflict? var value arc assignment relevant-vars)
	   (let ((weight (if (and *use-conflict-weight* *conflict-weight*)
			     (vector-ref *conflict-weight* (arc-index arc))
			     1)))
	     (set! count (+ weight count))
	     (if (and update-weight? *use-conflict-weight* *conflict-weight*)
		 (vector-set! *conflict-weight* (arc-index arc)
			      (+ *conflict-weight-increment* weight))))))
     arcs)
    count))

;;; Check for conflict for a var, value, and arc combination, given the
;;; full assignment and the list of other relevant vars.
(define (conflict? var value arc assignment relevant-vars)
  (let ((v1 (arc-tail arc))
	(v2 (arc-head arc))
	(constraint (arc-constraint-function arc)))
    ;; Before calling the constraint function we need to determine what
    ;; role the vars play in the constraint, since constraints may be
    ;; asymmetric with respect to the variables.
    (cond ((= v1 var)
	   (if (or (eq? relevant-vars #t) (member v2 relevant-vars))
	       (begin
		 (set! *number-of-arc-tests* (+ 1 *number-of-arc-tests*))
		 (not (constraint v1 value v2 (vector-ref assignment v2))))
	       #f))
	  ((= v2 var)
	   (if (or (eq? relevant-vars #t) (member v1 relevant-vars))
	       (begin
		 (set! *number-of-arc-tests* (+ 1 *number-of-arc-tests*))
		 (not (constraint v1 (vector-ref assignment v1) v2 value)))
	       #f))
	  (else 
	   #f))))

;;; Selects randomly among the values that achieve the min number of
;;; conflicts.
(define (select-min-randomly conflict-counts values)
  (let ((min-count (apply min conflict-counts))
	(positions '())
	(pos 0))
    (for-each (lambda (count)
		(if (= count min-count)
		    (set! positions (cons pos positions)))
		(set! pos (+ 1 pos)))
	      conflict-counts)
    (list-ref values (random-list-entry positions))
  ))

;;; PICKING VARS IN CONFLICT

(define (vars-in-conflict vars assignment relevant-vars update-weight?)
  (let ((sorted-vars
	 (sort
	  (map-non-false
	   vars
	   (lambda (var)
	     (let ((count
		    (count-conflicts-for-var-value
		     var (vector-ref assignment var) 
		     assignment relevant-vars update-weight?)))
	       (if (> count 0)
		   (list count var)
		   #f))))
	  (lambda (x y) (> (first x) (first y))))))
    (format #t "Conflicts: ~s~%" sorted-vars) ; prints list of (conflicts var)
    (map second sorted-vars)))

;;; CONSTRUCT INITIAL RANDOM ASSIGNMENT

(define (random-assignment)
  (let ((assignment (make-vector *number-of-variables*)))
    (for-each 
     (lambda (var) (vector-set! assignment var
				(random-list-entry (domain-of var))))
     *variables*)
    assignment))

;;; PRINTS DESCRIPTION OF CONFLICTING VARIABLES

(define (describe-conflicts n-conlict-vars conflict-vars assignment)
  (format #t "There are ~a vars involved in conflicts~%"
	  n-conlict-vars)
  (for-each 
   (lambda (var)
     (format #t "Var ~a (~a)=~a :" 
	     var (name-of var) (vector-ref assignment var))
     (for-each 
      (lambda (arc) 
	(let ((v (arc-head arc)))
	  (if (not ((arc-constraint-function arc) 
		    var (vector-ref assignment var) v (vector-ref assignment v)))
	      (format #t "~a (~a)=~a "
		      v (name-of v) (vector-ref assignment v)))))
      (arcs-from var))
     (for-each 
      (lambda (arc) 
	(let ((v (arc-tail arc)))
	  (if (not ((arc-constraint-function arc) 
		    v (vector-ref assignment v) var (vector-ref assignment var)))
	      (format #t "~a (~a)=~a "
		      v (name-of v) (vector-ref assignment v)))))
      (arcs-into var))
      (newline)
     )
   conflict-vars))