You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/csp/hacs-map.rkt

59 lines
2.6 KiB
Racket

#lang debug racket
(require "hacs.rkt" sugar/debug)
(module+ test (require rackunit))
(define (map-coloring-csp colors neighbors)
(define variables (remove-duplicates (flatten neighbors) eq?))
(define vds (for/list ([var (in-list variables)])
($var var colors)))
(define cs (for*/list ([neighbor neighbors]
[target (cdr neighbor)])
($constraint (list (car neighbor) target) neq?)))
($csp vds cs))
(define (parse-colors str) (map string->symbol (map string-downcase (regexp-match* "." str))))
(define(parse-neighbors str)
(define recs (map string-trim (string-split str ";")))
(for/list ([rec recs])
(match-define (cons head tail) (string-split rec ":"))
(map string->symbol (map string-downcase (map string-trim (cons head (string-split (if (pair? tail)
(car tail)
""))))))))
(current-inference forward-check)
(current-select-variable minimum-remaining-values)
(current-order-values shuffle)
(define aus (map-coloring-csp (parse-colors "RGB")
(parse-neighbors "SA: WA NT Q NSW V; NT: WA Q; NSW: Q V; T: ")))
(module+ test
(check-equal? (length (solve* aus)) 18))
(define usa (map-coloring-csp (parse-colors "RGBY")
(parse-neighbors "WA: OR ID; OR: ID NV CA; CA: NV AZ; NV: ID UT AZ; ID: MT WY UT;
UT: WY CO AZ; MT: ND SD WY; WY: SD NE CO; CO: NE KA OK NM; NM: OK TX;
ND: MN SD; SD: MN IA NE; NE: IA MO KA; KA: MO OK; OK: MO AR TX;
TX: AR LA; MN: WI IA; IA: WI IL MO; MO: IL KY TN AR; AR: MS TN LA;
LA: MS; WI: MI IL; IL: IN KY; IN: OH KY; MS: TN AL; AL: TN GA FL;
MI: OH IN; OH: PA WV KY; KY: WV VA TN; TN: VA NC GA; GA: NC SC FL;
PA: NY NJ DE MD WV; WV: MD VA; VA: MD DC NC; NC: SC; NY: VT MA CT NJ;
NJ: DE; DE: MD; MD: DC; VT: NH MA; MA: NH RI CT; CT: RI; ME: NH;
HI: ; AK:")))
(module+ test
(check-true (pair? (solve usa))))
(define fr (map-coloring-csp (parse-colors "RGBY")
(parse-neighbors "AL: LO FC; AQ: MP LI PC; AU: LI CE BO RA LR MP; BO: CE IF CA FC RA
AU; BR: NB PL; CA: IF PI LO FC BO; CE: PL NB NH IF BO AU LI PC; FC: BO
CA LO AL RA; IF: NH PI CA BO CE; LI: PC CE AU MP AQ; LO: CA AL FC; LR:
MP AU RA PA; MP: AQ LI AU LR; NB: NH CE PL BR; NH: PI IF CE NB; NO:
PI; PA: LR RA; PC: PL CE LI AQ; PI: NH NO CA IF; PL: BR NB CE PC; RA:
AU BO FC PA LR")))
(module+ test
(check-true (pair? (solve fr))))
(module+ main)