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

;;; 6.034 CSP examples: map coloring, Huffman-Clowes line labeling,
;;; class scheduling and N-queens.

;;; A sample constraint functions used in map coloring and course
;;; scheduling.  This illustrates the general calling convention for
;;; constraint functions.

(define (not-same? var1 value1 var2 value2)
  (not (equal? value1 value2)))

;;;;;;;;;;;;;;;;;
;;; Map coloring
;;;;;;;;;;;;;;;;;

(define *four-colors* '(red blue green yellow))
(define *five-colors* '(red blue green yellow purple))
(define *colors* *four-colors*)

(define *trivial-map*
  '((A Neighbors: B D E)
    (B Neighbors: A C E)
    (C Neighbors: B D E)
    (D Neighbors: A C E)
    (E Neighbors: A B C D)))

;;; The 48 contiguous regions of the US, with neighbors.  There may be
;;; errors in this, but it's close enough...

(define *US-48-states-map*
  '(
    (AL Neighbors: FL GA TN MS)
    (AR Neighbors: MO TN MS LA TX OK)
    (AZ Neighbors: NM CO UT NE CA)
    (CA Neighbors: OR NE AZ)
    (CO Neighbors: WY NB KS OK NM AZ UT)
    (CT Neighbors: NY MA RI)
    (DE Neighbors: NJ PA MD)
    (FL Neighbors: GA AL)
    (GA Neighbors: SC NC TN AL FL)
    (IA Neighbors: MN WI IL MO NB SD)
    (ID Neighbors: WA OR NE UT WY MT)
    (IL Neighbors: MI MO IA WI IN KY)
    (IN Neighbors: MI OH KY IL)
    (KS Neighbors: OK MO NB CO)
    (KY Neighbors: WV VA TN MO IL IN OH)
    (LA Neighbors: MS AR TX)
    (MA Neighbors: NH VT NY CT RI)
    (MD Neighbors: DE VA WV PA)
    (ME Neighbors: NH)
    (MI Neighbors: WI IL IN OH)
    (MN Neighbors: WI IA SD ND)
    (MO Neighbors: AR OK KS NB IA IL KY TN)
    (MS Neighbors: AL TN AR LA)
    (MT Neighbors: ND SD WY ID WA)
    (NB Neighbors: KS IA SD WY CO MO)
    (NC Neighbors: VA TN GA SC)
    (ND Neighbors: MN SD MT)
    (NE Neighbors: OR ID UT AZ CA)
    (NH Neighbors: VT MA ME)
    (NJ Neighbors: DE PA NY)
    (NM Neighbors: TX OK CO AZ UT)
    (NY Neighbors: VT MA CT NJ PA)
    (OH Neighbors: PA WV KY IN MI)
    (OK Neighbors: TX AR MO KS NM CO)
    (OR Neighbors: WA ID NE CA)
    (PA Neighbors: NY NJ DE MD WV OH)
    (RI Neighbors: MA CT)
    (SC Neighbors: NC GA)
    (SD Neighbors: NB WY MT ND IA MN)
    (TN Neighbors: AL VA NC GA MS AR MO KY)
    (TX Neighbors: LA AR OK NM)
    (UT Neighbors: CO NM AZ NE ID WY)
    (VA Neighbors: MD WV KY TN NC)
    (VT Neighbors: NY MA NH)
    (WA Neighbors: MT ID OR)
    (WI Neighbors: MI IL IA MN)
    (WV Neighbors: PA MD VA KY OH)
    (WY Neighbors: MT SD NB CO UT ID)
    ))

(define (initialize-map-coloring . args)
  (let ((map (if (null? args)
		 *US-48-states-map*
		 (car args))))
    (initialize (map-names-and-domains map)
		(map-constraint-arcs map))))

;;; Construct arcs.
(define (map-constraint-arcs regions)
  (let ((i-list (index-list regions))
	(arc-count 0))
    (append-map
     (lambda (region region-var)
       ;; If there are neighbors constrain them to not have the same
       ;; assignment. 
       (if (> (length region) 1)
	   (map (lambda (neighbor)
		  (let ((neighbor-region-var
			 (position neighbor regions first)))
		    (if neighbor-region-var
			(make-arc region-var
				  neighbor-region-var
				  not-same?
				  (set! arc-count (+ 1 arc-count)))
			(error 'map-constraint-arcs
			       "~%Could not find adjacent region ~s for ~s"
			       neighbor region))))
		(cddr region))
	   '()))
     regions
     i-list)))

;;; Simple, every region starts with same set of colors.
(define (map-names-and-domains regions)
  (map (lambda (region)
	 (cons (first region) *colors*))
       regions))

(define (test-map-coloring test-function . args)
  (let ((map (if (null? args)
		 *US-48-states-map*
	       (first args))))
    (set! *colors* *five-colors*)
    (format #t "Using 5 colors ~s~%" *colors*)
    (test-map-coloring-aux test-function map)
    (set! *colors* *four-colors*)
    (format #t "Using 4 colors ~s~%" *colors*)
    (test-map-coloring-aux test-function map)))

(define (test-map-coloring-aux test-function map)
  ;; map coloring
  (initialize-map-coloring map)
  (format #t "Testing with map~%")
  (do-test test-function)
  )

;;;;;;;;;;;;;;;;;
;;; Line labeling
;;;;;;;;;;;;;;;;;

;;; These are the legal junction labels (as in Chap 12).
;;; pos = +, neg = -, in = -<- (pointing in to junction) and out = ->-
;;; (pointing out of junction).

(define *legal-junction-labels*
  '((L (out in) (in out) (in pos) (pos out) (neg in) (out neg))
    (T (out in neg) (out in pos) (out in in) (out in out))
    (Fork (pos pos pos) (neg neg neg) (neg in out) (in out neg) (out neg in))
    (Arrow (pos pos neg) (in out pos) (neg neg pos))))

(define *cube-diagram*
  '((a Fork b c d)
    (b Arrow g e a)
    (c Arrow e f a)
    (d Arrow f g a)
    (e L c b)
    (f L d c)
    (g L b d)))

(define *tower-diagram*
  '((a Fork b c d)
    (b Arrow g e a)
    (c Arrow e f a)
    (d Arrow f g a)
    (e L c b)
    (f Fork d c i)
    (g Fork b d h)
    (h Arrow l g j)
    (i Arrow f m p)
    (j Fork h o k)
    (k Arrow m l j)
    (l L h k)
    (m L k i)
    (n L q o)
    (o Arrow y j n)
    (p L r i)
    (q Arrow n s w)
    (r Arrow s p x)
    (s L r q)
    (t Arrow w x z)
    (u Arrow x y z)
    (v Arrow y w z)
    (w Fork t v q)
    (x Fork r u t)
    (y Fork v u o)
    (z Fork t u v)))

(define (initialize-line-labeling . args)
  (let ((diagram (if (null? args)
		     *tower-diagram*
		   (car args))))
    (initialize (diagram-names-and-domains diagram)
		(diagram-constraint-arcs diagram))))

(define junction-name first)
(define junction-type second)
(define junction-neighbor-names cddr)

;;; Each junction gets the contents of the appropriate entry in
;;; *legal-junction-labels*.
(define (diagram-names-and-domains junctions)
  (map (lambda (junction)
	 (let ((legal-labels 
		(assoc (junction-type junction) *legal-junction-labels*)))
	   (if (not legal-labels)
	       (error 'junction-domains
		      "Could not find labels for junction ~s"
		      junction))
	   (cons (junction-name junction) (rest legal-labels))))
       junctions))

(define (diagram-constraint-arcs junctions)
  ;; junctions are in the form (junction-name junction-type . junction-neighbor-names)
  ;; junction-type is one of L, T, Fork, or Arrow.
  (let ((arc-count -1))
    (append-map
     (lambda (junction j-index)
       ;; Constructs a set of constraints, one for each line of a junction
       (map (lambda (neighbor-junction-name)
	      (let ((neighbor-junction
		     ;; get the junction corresponding to name.
		     (assoc neighbor-junction-name junctions)))
		(if (not neighbor-junction)
		    (error 'diagram-arcs
			   "Could not find ~s (in ~s) in junctions"
			   neighbor-junction-name junction))
		;; create the arc connecting neighboring junctions
		(make-arc j-index
			  (position neighbor-junction-name junctions first)
			  (line-label-constraint-function
			   (line-position neighbor-junction-name junction)
			   (line-position (junction-name junction) neighbor-junction))
			  (set! arc-count (+ 1 arc-count)))
		))
	    (junction-neighbor-names junction))
       )
     junctions
     (index-list junctions))))

;;; Where (0,1,2) in the list of neighbors does a junction name appear.
(define (line-position name junction)
  (let ((pos (position name (junction-neighbor-names junction))))
    (if pos
	pos
	(error line-position "Could not find ~s in ~s" name junction))))

(define (line-label-constraint-function pos1 pos2)
  (lambda (junction1 label1 junction2 label2)
    (let ((symbol1 (list-ref label1 pos1))
	  (symbol2 (list-ref label2 pos2)))
      (cond ((eq? symbol1 'pos) (eq? symbol2 'pos))
	    ((eq? symbol1 'neg) (eq? symbol2 'neg))
	    ((eq? symbol1 'in) (eq? symbol2 'out))
	    ((eq? symbol1 'out) (eq? symbol2 'in))))))

(define (test-line-labeling test-function . args)
  (let  ((diagram (if (null? args)
		      *tower-diagram*
		    (first args))))
    ;; Line Labeling
    (initialize-line-labeling diagram)
    (format #t "Testing with diagram~%")
    (do-test test-function)
    ))

;;;;;;;;;;;;;;;;;
;;; Course scheduling.
;;;;;;;;;;;;;;;;;

;;; In course-scheduling, the variables are the courses and the values
;;; are the terms.  Actually, instead of just terms, we use term-slots
;;; (fall 2 3) indicating the third slot in the fall term of the
;;; second year.  By using such slots and making sure that no two
;;; courses are assigned the same value, we can make sure we don't
;;; overload any term with courses.

;;; An entry is (course-name terms-offered PREREQS: . list-of-prereqs)
(define *course-requirements*
  '(
    (<5.11> (fall spring) PREREQS:)
    (<7.01X> (fall spring) PREREQS:)
    (<8.012> (fall spring) PREREQS:)
    (<8.022> (fall spring) PREREQS: <18.013> <8.012>)
    (<18.013> (fall spring) PREREQS:)
    (<18.023> (fall spring) PREREQS: <18.013>)
    (<18.03> (fall spring) PREREQS: <18.023>)
    (HASS-1 (fall) PREREQS:)
    (HASS-2 (spring) PREREQS:)
    (HASS-3 (fall) PREREQS: HASS-2)
    (HASS-4 (spring) PREREQS: HASS-2)
    (HASS-5 (fall) PREREQS: HASS-4)
    (HASS-6 (spring) PREREQS: HASS-4)
    (HASS-7 (fall) PREREQS: HASS-6)
    (HASS-8 (spring) PREREQS: HASS-6)
    (<6.001> (fall spring) PREREQS:)
    (<6.002> (fall spring) PREREQS: <18.03> <8.012>)
    (<6.003> (fall spring) PREREQS: <6.002> <6.001>)
    (<6.004> (fall spring) PREREQS: <6.002> <6.001>)
    (<6.033> (spring) PREREQS: <6.004>)
    (<6.034> (fall) PREREQS: <6.001>)
    (<6.042> (fall spring) PREREQS: <18.023>)
    (<6.046> (fall spring) PREREQS: <6.042> <6.001>)
    (<6.111> (fall spring) PREREQS: <6.002>)
    (<6.170> (spring) PREREQS: <6.001>)
    (SENIOR-OR-GRAD () PREREQS:)
    (<6.835> (fall) PREREQS: SENIOR-OR-GRAD <6.034> <6.001>)
    (<6.824> (fall) PREREQS: SENIOR-OR-GRAD)
    (<6.823> (fall) PREREQS: SENIOR-OR-GRAD <6.004>)
    (<6.840> (fall) PREREQS: SENIOR-OR-GRAD <6.046>)
    (<6.863> (spring) PREREQS: SENIOR-OR-GRAD <6.034>)
    (GRAD () PREREQS:)
    (<6.THG-FALL> (fall) PREREQS: GRAD)
    (<6.THG-SPRING> (spring) PREREQS: <6.THG-FALL>))
  )

(define (initialize-course-scheduling . args)
  (let ((courses (if (null? args)
		     *course-requirements*
		   (car args))))
    (initialize (course-names-and-domains courses)
		(course-constraint-arcs courses))))
      
;;; Construct a list of variable names with associated domains, e.g.
;;; (<6.001> (fall 1 1) (fall 1 2) ... (spring 5 4))
;;; Each domain entry corresponds to a term and a slot (from 1 to 4).
;;; The slot is there so as to easily enforce a limit of four courses
;;; a term.
(define (course-names-and-domains courses)
  (map (lambda (course) 
	 ;; Some pseudo-courses are fixed in time.
	 (if (eq? (first course) 'SENIOR-OR-GRAD)
	     '(SENIOR-OR-GRAD (spring 3 0))
	   (if (eq? (first course) 'GRAD)
	       '(GRAD (spring 4 0))
	     (cons (first course)
		   (append-map 
		    (lambda (term)
		      (if (member (first term) (second course))
			  (map (lambda (slot)
				 (append term (list slot)))
			       '(1 2 3 4))
			  '()))
		    '((fall 1) (spring 1)
		      (fall 2) (spring 2)
		      (fall 3) (spring 3)
		      (fall 4) (spring 4)
		      (fall 5) (spring 5)))))))
       courses))

;;; Construct the arcs given courses and their prereqs.
(define (course-constraint-arcs courses)
  (let ((i-list (index-list courses))
	(arc-count -1))
    (append-map
     (lambda (course course-var)
       (append
	;; arcs that represent the constraint that a course must be
	;; scheduled after any prereqs. 
	(if (> (length course) 2)	; there are prereqs.
	    (append-map 
	     (lambda (prereq)
	       (let ((prereq-course-var
		      (position prereq courses first)))
		 (if prereq-course-var
		     (list 
		      (make-arc course-var
				prereq-course-var
				course-after-prereq?
				(set! arc-count (+ 1 arc-count)))
		      (make-arc prereq-course-var
				course-var
				prereq-before-course?
				(set! arc-count (+ 1 arc-count))))
		     (error 'constraint-arcs
			    "~%Could not find prereq course ~s for ~s"
			    prereq course))))
	     (cdr (member 'prereqs: course)))
	    '())
	;; arcs that ensure that courses are not assigned to the same
	;; "term slot", that is, (term year slot).
	(append-map
	 (lambda (other-course-var)
	   (if (not (= course-var other-course-var))
	       (list (make-arc course-var
			       other-course-var
			       not-same?
			       (set! arc-count (+ 1 arc-count))))
	       '()))
	 i-list))
       )
     courses 
     i-list)))

(define (course-after-prereq? var1 value1 var2 value2)
  (subsequent-term? (first value2) (second value2) ; prereq
		    (first value1) (second value1)))

(define (prereq-before-course? var1 value1 var2 value2)
  (subsequent-term? (first value1) (second value1) ; prereq
		    (first value2) (second value2)))

(define (subsequent-term? term1 year1 term2 year2)
  (if (= year1 year2)
      (and (eq? term1 'fall) (eq? term2 'spring))
      (< year1 year2)))

(define (test-course-scheduling test-function . args)
  (let ((courses (if (null? args)
		     *course-requirements*
		   (first args))))
    ;; Course Requirements
    (initialize-course-scheduling courses)
    (format #t "Testing with courses~%")
    (do-test test-function)
    ))

;;;;;;;;;;;;;;;;;
;;; N-Queens
;;;;;;;;;;;;;;;;;

(define (initialize-n-queens n)
  (initialize (queen-names-and-domains 0 n)
	      (queen-constraint-arcs 0 n 0)))

;;; A queen is attached to a column, the domain represents the row
;;; where it is to be placed.  This already builds in constraint that
;;; queens cannot safely occupy the same column.
(define (queen-names-and-domains count n)
  (if (= count n)
      '()
    (cons (cons count (make-index-list n))
	  (queen-names-and-domains (+ 1 count) n))))

;;; The constraint function checks to see if queens can attack each
;;; other.
(define (queens-safe var1 val1 var2 val2)
  (not
   ;; conditions for attacking.
   (or (= val1 val2)			; same row
       (= (abs (- var1 var2)) (abs (- val1 val2))) ; diagonal
       )))

;;; This produces (almost) n^2 arcs, every queen needs to check every
;;; other queen (except itself).  Recall that arcs are directional.
(define (queen-constraint-arcs j n count)
  (define (queen-constraint-arcs-aux k ct)
    (if (>= k n)
	(queen-constraint-arcs (+ 1 j) n ct)
	(if (= j k)			; no self loops.
	    (queen-constraint-arcs-aux (+ 1 k) ct)
	    (cons (make-arc j k queens-safe ct)
		  (queen-constraint-arcs-aux (+ 1 k) (+ 1 ct))))
	))
  (if (>= j n)
      '()
      (queen-constraint-arcs-aux 0 count)))

(define (test-n-queens test-function . args)
  (let ((n-list (or args '(15))))
    ;; n-queens
    (define (n-queens-test l)
      (if (null? l)
	  #f
	(begin
	 (initialize-n-queens (first l))
	 (format #t "Testing with ~s queens~%" (first l))
	 (do-test test-function)
	 (n-queens-test (rest l)))))
    (n-queens-test n-list)
    ))