結果
| 問題 |
No.1156 Nada Picnic 2
|
| ユーザー |
 norioc
|
| 提出日時 | 2025-07-06 21:27:41 |
| 言語 | Scheme (Gauche-0.9.15) |
| 結果 |
AC
|
| 実行時間 | 223 ms / 2,000 ms |
| コード長 | 7,728 bytes |
| コンパイル時間 | 459 ms |
| コンパイル使用メモリ | 8,480 KB |
| 実行使用メモリ | 30,324 KB |
| 最終ジャッジ日時 | 2025-07-06 21:27:43 |
| 合計ジャッジ時間 | 2,560 ms |
|
ジャッジサーバーID （参考情報） |
judge5 / judge4 |
（要ログイン）
| ファイルパターン | 結果 |
|---|---|
| other | AC * 3 |
ソースコード
(use scheme.list)
(use util.match)
(use srfi.13) ; string
(use srfi.42) ; list-ec
(use srfi.197) ; chain
(use gauche.collection)
(use gauche.generator)
(use gauche.sequence)
(define input read-line)
(define (ii)
(string->number (read-line)))
(define (li)
(let ((s (read-line)))
(map string->number (string-split s " "))))
(define (prn . args)
(for-each-with-index (lambda (i x)
(when (> i 0)
(display " "))
(display x))
args)
(newline))
(define prn* (pa$ apply prn))
(define int string->number)
(define str x->string)
(define-method min ((xs <sequence>))
(fold min (~ xs 0) xs))
(define-method max ((xs <sequence>))
(fold max (~ xs 0) xs))
(define (minmax . xs)
(values->list (apply min&max xs)))
(define-method minmax ((xs <sequence>))
(values->list (apply min&max xs)))
(define (sum xs)
(fold + 0 xs))
(define (divmod a b)
(values->list (div-and-mod a b)))
(define (1+ n) (+ n 1))
(define (1- n) (- n 1))
(define (!= a b) (not (= a b)))
(define pow
(case-lambda
((a b) (expt a b))
((a b m) (expt-mod a b m))))
(define gcd* (apply$ gcd))
(define isqrt exact-integer-sqrt)
(define ++ string-append)
(define zip (map$ list))
(define (pairwise xs)
(zip xs (cdr xs)))
(define (comb n k)
(if (or (< k 0) (> k n))
0
(let loop ((i 0)
(x 1))
(if (= i k)
x
(loop (1+ i) (div (* x (- n i)) (1+ i)))))))
(define-method frequencies ((xs <sequence>))
(rlet1 ht (make-hash-table eqv-comparator)
(for-each (^x (hash-table-update! ht x 1+ 0))
xs)))
(define (yn b)
(prn (if b "Yes" "No")))
(define-macro (input! bindings . body)
(let loop ((bs (reverse bindings))
(res '()))
(if (null? bs)
`(let*-values ,res
,@body)
(cond
((symbol? (car bs))
(loop (cdr bs)
(cons `((,(car bs)) (values (ii)))
res)))
((list? (car bs))
(loop (cdr bs)
(cons `(,(car bs) (apply values (li)))
res)))
(else
'error)))))
(define mlet1 match-let1)
(define-macro (mfn pat . body)
(let ((arg (gensym)))
`(lambda (,arg)
(mlet1 ,pat ,arg
,@body))))
(define-syntax count-ec
(syntax-rules ()
((_ qualifiers ...)
(sum-ec qualifiers ... 1))))
(define (len obj)
(cond
((list? obj) (length obj))
((string? obj) (string-length obj))
(else
(assume #f))))
(define (accum xs)
(define (proc a b)
(let1 t (+ a b)
(values t t)))
(map-accum proc 0 xs))
(define (digits n)
(map digit->integer (str n)))
(define (-> x . fns)
(call-with-values (^() (values x))
(apply compose (reverse fns))))
(define (rep n thunk)
(list-tabulate n (^i (thunk))))
(use util.combinations)
(use gauche.dictionary)
(define (zip-longest . args)
(let* ((n (apply max (map length args)))
(xxs (map (^(xs)
(append xs (make-list (- n (length xs)) #f)))
args)))
(map (pa$ delete #f)
(apply zip xxs))))
;; 文字群 chars への数字群 digits の割り当て
(define (gen-assign chars digits)
(assume (<= (len chars) (len digits)))
(generate (^(yield)
(combinations-for-each
(^(ds)
(permutations-for-each
(^(ps)
(yield (map (^(a b) (cons a b)) chars ps)))
ds))
digits
(len chars)))))
(define (-solve xxs yys)
(let ((chars (delete-duplicates (append (concatenate xxs)
(concatenate yys))))
(leading-chars (delete-duplicates (append (map car xxs) (map car yys)))))
(define (cdr* lis)
(if (null? lis) '() (cdr lis)))
(define (char->index c)
(find-index (pa$ eqv? c) chars))
;; 文字 c に数字 d を割り当てられるか
(define (valid-char? c d)
(if (zero? d)
(not (memv c leading-chars))
#t))
;; cs のうち未割り当ての文字を返す
(define (collect-unassigned-chars cs tab)
(filter (^c
(let ((ind (char->index c)))
(eqv? #f (~ tab ind))))
cs))
;; 未割り当ての数字
(define (collect-unassigned-digits tab)
(let ((v (make-vector 10 #f)))
(dotimes (i 10)
(let ((d (~ tab i)))
(if d
(set! (~ v d) #t))))
(filter (^i (eq? #f (~ v i))) (iota 10))))
;; 文字 c に割り当てた数字を返す(未割り当てなら #f)
(define (char->digit c tab)
(let ((ind (char->index c)))
(~ tab ind)))
;; 文字に割り当てた数字の和(文字が存在しないなら0を返す)
(define (sum-car-chars ccs tab)
(if (null? ccs)
0
(sum (map (^c
(let ((d (char->digit c tab)))
(assume (not (eqv? d #f)))
d))
(car ccs)))))
(define (convert xxs yys tab)
(define (word cs)
(string-join (map (^c (str (~ tab (char->index c)))) cs) ""))
(let ((lhs (map word xxs))
(rhs (map word yys)))
(list lhs rhs)))
(assume (<= (len chars) 10))
;; 一の位の桁から数字を割り当てていく
(let ((lefts (apply zip-longest (map reverse xxs)))
(rights (apply zip-longest (map reverse yys)))
(tab (make-vector 10 #f))) ; 文字インデックス : 割り当てる数字
(generate
(^(yield)
(let loop ((lefts lefts)
(rights rights)
(lcarry 0)
(rcarry 0))
(cond
((and (null? lefts)
(null? rights))
(when (and (zero? lcarry)
(zero? rcarry))
(yield (convert xxs yys tab))))
(else
(let ((cs (collect-unassigned-chars (delete-duplicates
(append (if (null? lefts) '() (car lefts))
(if (null? rights) '() (car rights))))
tab)))
(generator-for-each
(^(binds)
(when (every (^(kv) (valid-char? (car kv) (cdr kv))) binds)
(dolist (kv binds)
(set! (~ tab (char->index (car kv))) (cdr kv)))
(let ((l (sum-car-chars lefts tab))
(r (sum-car-chars rights tab)))
(when (= (mod (+ l lcarry) 10)
(mod (+ r rcarry) 10))
(loop (cdr* lefts)
(cdr* rights)
(div (+ l lcarry) 10)
(div (+ r rcarry) 10))))
;; 割り当てを戻す
(dolist (kv binds)
(set! (~ tab (char->index (car kv))) #f))))
(if (null? cs)
(generator '())
(gen-assign cs (collect-unassigned-digits tab))))))))
)))))
(define (solve xxs yys)
(-solve (map string->list xxs)
(map string->list yys)))
(input! (N)
(->
(case N
((1) (solve '("シイタ" "ケヤマ") '("イキタイ")))
((2) (solve '("オオツカ" "コクサイ") '("ビジツカン")))
((3) (solve '("spring" "eight") '("picnic"))))
(^g (mlet1 (a b) (g)
(prn (car b))))))