Last active
January 10, 2021 00:38
-
-
Save k16shikano/0be7b0a72cf9c13af22ba9649cf6277f to your computer and use it in GitHub Desktop.
「九個の?」パズルを解く
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
; 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)) |
Author
k16shikano
commented
Jan 9, 2021
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment