shithub: sl

ref: bbfee60f6716dce8cf7a802c044cf7d0fe8bb6f2
dir: /test/color.sl/

; dictionaries ----------------------------------------------------------------
(def (dict-new) NIL)

(def (dict-extend dl key value)
  (cond ((not dl)                (list (cons key value)))
        ((equal? key (caar dl))  (cons (cons key value) (cdr dl)))
        (else                    (cons (car dl) (dict-extend (cdr dl) key value)))))

(def (dict-lookup dl key)
  (cond ((not dl)                NIL)
        ((equal? key (caar dl))  (cdar dl))
        (else                    (dict-lookup (cdr dl) key))))

(def (dict-keys dl) (map car dl))

; graphs ----------------------------------------------------------------------
(def (graph-empty) (dict-new))

(def (graph-connect g n1 n2)
  (dict-extend
   (dict-extend g n2 (cons n1 (dict-lookup g n2)))
   n1
   (cons n2 (dict-lookup g n1))))

(def (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1)))

(def (graph-neighbors g n) (dict-lookup g n))

(def (graph-nodes g) (dict-keys g))

(def (graph-add-node g n1) (dict-extend g n1 NIL))

(def (graph-from-edges edge-list)
  (if (not edge-list)
      (graph-empty)
      (graph-connect (graph-from-edges (cdr edge-list))
                     (caar edge-list)
                     (cdar edge-list))))

; graph coloring --------------------------------------------------------------
(def (node-colorable? g coloring node-to-color color-of-node)
  (not (member
        color-of-node
        (map
         (λ (n)
           (let ((color-pair (assq n coloring)))
             (and (cons? color-pair) (cdr color-pair))))
         (graph-neighbors g node-to-color)))))

(def (try-each f lst)
  (if (not lst) nil
      (let ((ret (f (car lst))))
        (if ret ret (try-each f (cdr lst))))))

(def (color-node g coloring colors uncolored-nodes color)
  (cond
   ((not uncolored-nodes) coloring)
   ((node-colorable? g coloring (car uncolored-nodes) color)
    (let ((new-coloring
           (cons (cons (car uncolored-nodes) color) coloring)))
      (try-each (λ (c)
                  (color-node g new-coloring colors (cdr uncolored-nodes) c))
                colors)))))

(def (color-graph g colors)
  (if (not colors)
      (and (not (graph-nodes g)) nil)
      (color-node g NIL colors (graph-nodes g) (car colors))))

(def (color-pairs pairs colors)
  (color-graph (graph-from-edges pairs) colors))

; queens ----------------------------------------------------------------------
(def (can-attack x y)
  (let ((x1 (mod x 5))
        (y1 (truncate (/ x 5)))
        (x2 (mod y 5))
        (y2 (truncate (/ y 5))))
    (or (= x1 x2) (= y1 y2) (= (abs (- y2 y1)) (abs (- x2 x1))))))

(def (generate-5x5-pairs)
  (let ((result NIL))
    (dotimes (x 25)
      (dotimes (y 25)
        (when (and (/= x y) (can-attack x y))
          (set! result (cons (cons x y) result)))))
    result))