86 lines
2.1 KiB
Racket
86 lines
2.1 KiB
Racket
#lang racket
|
|
|
|
(require (except-in "../schelog.rkt" %member))
|
|
|
|
;map coloring, example from Sterling & Shapiro, p. 212
|
|
|
|
;(%member x y) holds if x is in y
|
|
|
|
;; is this different from the %member provided by schelog? fencing that one out.
|
|
|
|
(define %member
|
|
(%rel (X Xs Y Ys)
|
|
((X (cons X Xs)))
|
|
((X (cons Y Ys)) (%member X Ys))))
|
|
|
|
;(%members x y) holds if x is a subset of y
|
|
|
|
(define %members
|
|
(%rel (X Xs Ys)
|
|
(((cons X Xs) Ys) (%member X Ys) (%members Xs Ys))
|
|
(('() Ys))))
|
|
|
|
;(%select x y z) holds if z is y with one less occurrence of x
|
|
|
|
(define %select
|
|
(%rel (X Xs Y Ys Zs)
|
|
((X (cons X Xs) Xs))
|
|
((X (cons Y Ys) (cons Y Zs))
|
|
(%select X Ys Zs))))
|
|
|
|
;region is a structure-builder
|
|
|
|
(define region
|
|
(lambda (name color neighbors)
|
|
(list 'region name color neighbors)))
|
|
|
|
(define %color-map
|
|
(%rel (Region Regions Colors)
|
|
(((cons Region Regions) Colors)
|
|
(%color-region Region Colors) (%color-map Regions Colors))
|
|
(('() Colors))))
|
|
|
|
(define %color-region
|
|
(%rel (Name Color Neighbors Colors Colors1)
|
|
(((region Name Color Neighbors) Colors)
|
|
(%select Color Colors Colors1)
|
|
(%members Neighbors Colors1))))
|
|
|
|
(define %test-color
|
|
(%rel (Name Map Colors)
|
|
((Name Map)
|
|
(%map Name Map)
|
|
(%colors Colors)
|
|
(%color-map Map Colors))))
|
|
|
|
(define %map
|
|
(%rel (A B C D E F G H I L P S)
|
|
(('test (list
|
|
(region 'a A (list B C D))
|
|
(region 'b B (list A C E))
|
|
(region 'c C (list A B D E F))
|
|
(region 'd D (list A C F))
|
|
(region 'e E (list B C F))
|
|
(region 'f F (list C D E)))))
|
|
(('western-europe
|
|
(list
|
|
(region 'portugal P (list E))
|
|
(region 'spain E (list F P))
|
|
(region 'france F (list E I S B G L))
|
|
(region 'belgium B (list F H L G))
|
|
(region 'holland H (list B G))
|
|
(region 'germany G (list F A S H B L))
|
|
(region 'luxembourg L (list F B G))
|
|
(region 'italy I (list F A S))
|
|
(region 'switzerland S (list F I A G))
|
|
(region 'austria A (list I S G)))))))
|
|
|
|
(define %colors
|
|
(%rel ()
|
|
(('(red yellow blue white)))))
|
|
|
|
;ask (%which (M) (%test-color 'test M)) or
|
|
;ask (%which (M) (%test-color 'western-europe M)) for the
|
|
;respective (non-unique) colorings.
|
|
|