「九個の？」パズルを解く

9q.scm

; solver for the "9 questions" quize
; http://flash10000.com/archives/823413.html

; https://note.golden-lucky.net/2006/05/1998java-httpwww.html

(use srfi-1)

(define row 9)
(define line 8)
(define q-num 9)

;; question-mark
(define (face s n)
  (call/cc (lambda (break)
    (cond ((= n 1)
           (if (or (> (+ (remainder s row) 2) row) (> (+ (quotient s row) 6) line))
               (break '())
               (list s                (+ s 1)           ; **
                                      (+ s row 1)       ;  *
                     (+ s (* 2 row)) (+ s (* 2 row) 1)  ; **
                     (+ s (* 3 row))                    ; * 
                                                        ;   
                     (+ s (* 5 row)))))                 ; * 
          ((= n 2)
           (if (or (> (+ (remainder s row) 2) row) (> (+ (quotient s row) 6) line))
               (break '())
               (list s               (+ s 1)            ; **
                     (+ s row)                          ; * 
                     (+ s (* 2 row)) (+ s (* 2 row) 1)  ; **
                                     (+ s (* 3 row) 1)  ;  *
                                                        ;   
                                     (+ s (* 5 row) 1)  ;  *
                     )))
          ((= n 3)
           (if (or (> (+ (remainder s row) 2) row) (> (+ (quotient s row) 6) line))
               (break '())
               (list                 (+ s 1)            ;  *
                                                        ;   
                                     (+ s (* 2 row) 1)  ;  *
                     (+ s (* 3 row)) (+ s (* 3 row) 1)  ; **
                     (+ s (* 4 row))                    ; * 
                     (+ s (* 5 row)) (+ s (* 5 row) 1)  ; **
                     )))
          ((= n 4)
           (if (or (> (+ (remainder s row) 2) row) (> (+ (quotient s row) 6) line))
               (break '())
               (list s                                  ; * 
                                                        ;   
                     (+ s (* 2 row))                    ; * 
                     (+ s (* 3 row)) (+ s (* 3 row) 1)  ; **
                                     (+ s (* 4 row) 1)  ;  *
                     (+ s (* 5 row)) (+ s (* 5 row) 1)  ; **
                     )))
          ((= n 5)
           (if (or (> (+ (remainder s row) 6) row) (> (+ (quotient s row) 2) line))
               (break '())
               (list s (+ s 2) (+ s 3) (+ s 5)           ; * ** *
                     (+ s row) (+ s row 1) (+ s row 2)   ; ***
                     )))
          ((= n 6)
           (if (or (> (+ (remainder s row) 6) row) (> (+ (quotient s row) 2) line))
               (break '())
               (list s (+ s 2) (+ s 3) (+ s 5)           ; * ** *
                     (+ s row 3) (+ s row 4) (+ s row 5) ;    ***
                     )))
          ((= n 7)
           (if (or (> (+ (remainder s row) 6) row) (> (+ (quotient s row) 2) line))
               (break '()) 
               (list s (+ s 1) (+ s 2)                             ; ***
                     (+ s row) (+ s row 2) (+ s row 3) (+ s row 5) ; * ** * 
                     )))
          ((= n 8)
           (if (or (> (+ (remainder s row) 6) row) (> (+ (quotient s row) 2) line))
               (break '())
               (list (+ s 3) (+ s 4) (+ s 5)                       ;    ***
                     (+ s row) (+ s row 2) (+ s row 3) (+ s row 5) ; * ** *
                     )))))))

;; available question-mark faces
(define valid-face-list
  (filter (lambda (x) (not (null? x)))
    (let fs ((s 0))
      (if (> s (- (* row line) 1))
          '()
          (let fn ((n 1))
            (if (> n 8)
                (fs (+ s 1))
                (cons (face s n) (fn (+ n 1)))))))))

;; check if two lists are distinct with each other
(define (distinct? l1 l2)
  (= (length (lset-union eq? l1 l2))
     (+ (length l1) (length l2))))

(define (distinct-cdr ls)
  (let R ((tail (cdr ls)))
    (cond ((null? tail) '())
   ((not (distinct? (car ls) (car tail)))
    (R (cdr tail)))
   (else
    (cons (car tail) (R (cdr tail)))))))

(define (trim-combinations ls n proc)
  (cond ((> n (length ls))
         '())
        ((= n 1)
         (map list ls))
        ((> (- n 1) (length (proc ls)))
         (trim-combinations (cdr ls) n proc))
        (else
         (append
          (map (lambda (x) (cons (car ls) x))
               (trim-combinations (proc ls) (- n 1) proc))
          (trim-combinations (cdr ls) n proc)))))

(define (drawq qs)
  (map
   (^q
     #"~(* 20 (mod q row)) ~(* 20 (div q row)) 20 20 rectfill")
   qs))

(define (setcolor c)
  (define (rgb web)
    (let ((r (string->number #"#x~(substring web 0 2)"))
          (g (string->number #"#x~(substring web 2 4)"))
          (b (string->number #"#x~(substring web 4 6)")))
      #"~(/. r 255) ~(/. g 255) ~(/. b 255)"))
  
  (case c
    ((1) (rgb "000000"))
    ((2) (rgb "006400"))
    ((3) (rgb "ff0000"))
    ((4) (rgb "ffd700"))
    ((5) (rgb "0000cd"))
    ((6) (rgb "00ff00"))
    ((7) (rgb "1e90ff"))
    ((8) (rgb "ff69b4"))
    ((9) (rgb "ffebcd"))))

(define (drawqs qs)
  (map
   (^(q color)
     (print #"~(setcolor color) setrgbcolor ~(string-join (drawq q))"))
   qs (iota (length qs) 1))
  (print "showpage"))

(print #"<< /PageSize [~(* row 20) ~(* line 20)] >> setpagedevice")
(map drawqs (trim-combinations valid-face-list q-num distinct-cdr))

$ time gosh 9q.scm > result.ps

real    15m42.515s
user    22m18.208s
sys     0m18.938s

$ cat /proc/cpuinfo
processor       : 0
vendor_id       : GenuineIntel
cpu family      : 6
model           : 86
model name      : Intel(R) Xeon(R) CPU D-1518 @ 2.20GHz
stepping        : 3
microcode       : 0x700000d
cpu MHz         : 844.627
cache size      : 6144 KB
...

$  cat /proc/meminfo
MemTotal:       32757148 kB
...