お断り
チケットの高額売買に関する問題の事ではありません。
なお、チケットに限らず転売屋は地獄に堕ちてください。
お断り ここまで
さて、今回のお題です。
チケットナンバー問題で、もっとも計算方法が多い４桁の数字はいくつか。
最小の値を答えよ。
プログラムです。
(define nil '())
(define (enumerate-interval low high)
(if (> low high)
nil
(cons low (enumerate-interval (+ low 1) high))))
(define (filter predicate seq)
(cond ((null? seq) nil)
((predicate (car seq))
(cons (car seq) (filter predicate (cdr seq))))
(else (filter predicate (cdr seq)))))
(define (accumulate op initial seq)
(if (null? seq)
initial
(op (car seq)
(accumulate op initial (cdr seq)))))
(define (flatmap proc seq)
(accumulate append nil (map proc seq)))
(define (remove item seq)
(filter (lambda (x) (not (eq? x item))) seq))
(define *stack* nil)
(define level-ratio 100)
(define (last-pushed)
(if (empty?)
nil
(car *stack*)))
(define (after-popped)
(if (empty?)
nil
(cdr *stack*)))
(define (init-stack)
(set! *stack* nil))
(define (empty?)
(null? *stack*))
(define (push x)
(set! *stack* (cons x *stack*)))
(define (pop)
(if (empty?)
nil
(let ((result (last-pushed)))
(set! *stack* (after-popped))
result)))
(define (pop-all level)
(define (iter ops)
(if (or (empty?) (< (priority (last-pushed)) (* level level-ratio)))
ops
(iter (append ops (cons (operator (pop)) nil)))))
(iter nil))
(define (make-priority op level)
(let ((priority
(cond ((eq? op '*) 20)
((eq? op '/) 20)
((eq? op '+) 10)
((eq? op '-) 10)
(else 0))))
(cons op (+ priority (* level level-ratio)))))
(define (operator p)
(car p))
(define (priority p)
(if (null? p)
0
(cdr p)))
(define (operator? x)
(or (eq? x '+) (eq? x '-) (eq? x '*) (eq? x '/)))
(define (exchange-operator op level)
(define (iter ops)
(if (or (empty?) (< (priority (last-pushed)) (priority (make-priority op level))))
ops
(iter (append ops (cons (operator (pop)) nil)))))
(iter nil))
(define (exp->rpn exp)
(define (iter e r level)
(if (null? e)
(append r (pop-all level))
(if (list? (car e))
(iter (cdr e) (iter (car e ) r (+ level 1)) level)
(cond ((operator? (car e))
(let ((ops (exchange-operator (car e) level)))
(push (make-priority (car e) level))
(iter (cdr e) (append r ops) level)))
(else (iter (cdr e) (append r (list (car e))) level))))))
(init-stack)
(iter exp nil 0))
(define (eval-rpn rpn)
(define (iter r)
(if (null? r)
(pop)
(let ((e (car r)))
(cond ((eq? e '+)
(let ((addend (pop)))
(push (+ (pop) addend))))
((eq? e '-)
(let ((subtrahend (pop)))
(push (- (pop) subtrahend))))
((eq? e '*)
(let ((multiplier (pop)))
(push (* (pop) multiplier))))
((eq? e '/)
(let ((divisor (pop)))
(if (= divisor 0)
(error "attempt to calculate a division by zero")
(push (/ (pop) divisor)))))
(else (push e)))
(iter (cdr r)))))
(init-stack)
(guard (e ((<error> e) -999))
(iter rpn)))
(define (build-exp o d)
(if (null? o)
nil
(cons (car o) (cons (car d) (build-exp (cdr o) (cdr d))))))
(define (ins-parentheses exp)
(let ((a (list-ref exp 0))
(op1 (list-ref exp 1))
(b (list-ref exp 2))
(op2 (list-ref exp 3))
(c (list-ref exp 4))
(op3 (list-ref exp 5))
(d (list-ref exp 6)))
`(
(((,a ,op1 ,b) ,op2 ,c) ,op3 ,d)
((,a ,op1 (,b ,op2 ,c)) ,op3 ,d)
(,a ,op1 ((,b ,op2 ,c) ,op3 ,d))
(,a ,op1 (,b ,op2 (,c ,op3 ,d)))
((,a ,op1 ,b) ,op2 (,c ,op3 ,d))
)))
(define (build-exps ops dgt)
(map cdr (map (lambda (o) (build-exp (cons '_ o) dgt)) ops)))
(define (num->lst n d)
(let* ((num-lst (map digit->integer (string->list (number->string n))))
(len (length num-lst)))
(if (< len d)
(append (make-list (- 4 len) 0) num-lst)
num-lst)))
(define (lst->num num-lst)
(define (iter lst sum)
(if (null? lst)
sum
(iter (cdr lst) (+ (* sum 10) (car lst)))))
(if (null? num-lst)
nil
(iter num-lst 0)))
(define (permutations s c)
(if (or (= c 0) (null? s))
(list nil)
(flatmap (lambda (x)
(map (lambda (p) (cons x p))
(permutations (remove x s) (- c 1))))
s)))
(define (repeated-permutations s n)
(if (= n 0)
(list nil)
(flatmap (lambda (x)
(map (lambda (p) (cons x p)) (repeated-permutations s (- n 1))))
s)))
(define (make-nums)
(define (iter d1 d2 d3 d4 lis)
(cond ((< d1 0) lis)
((< d2 d1) (iter (- d1 1) 9 9 9 lis))
((< d3 d2) (iter d1 (- d2 1) 9 9 lis))
((< d4 d3) (iter d1 d2 (- d3 1) 9 lis))
(else (iter d1 d2 d3 (- d4 1) (cons (list d1 d2 d3 d4) lis)))))
(iter 9 9 9 9 nil))
(define (lst->ulst lst)
(define (iter l m n)
(if (null? l)
m
(iter (cdr l) (append m (cons (+ (car l) n) nil)) (+ n 10))))
(iter lst nil 10))
(define (ulst->lst ulst)
(map (lambda (x) (remainder x 10)) ulst))
(define operators (repeated-permutations (list '+ '- '* '/) 3))
(define digits (make-nums))
(define (list<=? lst1 lst2)
(define operators-order '(+ - * /))
(define (iter l1 l2)
(cond ((null? l1) #t)
((or (not (number? (car l1))) (not (number? (car l2))))
(let ((ord1 (length (memq (car l1) operators-order)))
(ord2 (length (memq (car l2) operators-order))))
(> ord1 ord2)))
((< (car l1) (car l2)) #t)
((> (car l1) (car l2)) #f)
(else (iter (cdr l1) (cdr l2)))))
(let ((len1 (length lst1))
(len2 (length lst2)))
(cond ((< len1 len2) #t)
((> len1 len2) #f)
(else (iter lst1 lst2)))))
(define (sort-rpn v1 op v2)
(cond ((and (number? v1) (number? v2))
(if (< v1 v2)
(list v1 op v2)
(list v2 op v1)))
((number? v1)
(list v1 op v2))
((number? v2)
(list v2 op v1))
(else
(if (list<=? v1 v2)
(list v1 op v2)
(list v2 op v1)))))
(define (analyze-rpn rpn)
(define (iter r)
(if (null? r)
(pop)
(let ((e (car r)))
(cond ((eq? e '+)
(let ((addend (pop)))
(push (sort-rpn (pop) e addend))))
((eq? e '-)
(let ((subtrahend (pop)))
(push (list (pop) e subtrahend))))
((eq? e '*)
(let ((multiplier (pop)))
(push (sort-rpn (pop) e multiplier))))
((eq? e '/)
(let ((divisor (pop)))
(if (and (number? divisor) (= divisor 0))
(error "attempt to calculate a division by zero")
(push (list (pop) e divisor)))))
(else (push e)))
(iter (cdr r)))))
(init-stack)
(guard (e ((<error> e) nil))
(iter rpn)))
(define (ticket-numbers total)
(define (iter ns lst)
(if (null? ns)
lst
(let* ((nums (permutations (lst->ulst (car ns)) 4))
(result (filter (lambda (exp) (= (eval-rpn (exp->rpn exp)) total))
(flatmap ins-parentheses (flatmap (lambda (num) (build-exps operators num)) (map ulst->lst nums))))))
(iter (cdr ns) (if (null? result) lst (cons (car ns) lst))))))
(iter digits nil))プログラムの基本は「総当たり解法」です。４つの数字と数字の間に入る３つの四則演算子の組み合わせをすべて作成して式を作ります。
乗算・除算よりも加算・減算を先に計算したい場合もあるため、計算の順序も考慮するようにカッコも導入します。
この式にカッコを入れるの場所の組み合わせは、５通りあります。(ins-parentheses 手続き参照)
人間であれば容易いですが、出来上がった普通の計算式をそのままプログラムで計算するのはとても面倒になるため、生成した計算式を逆ポーランド記法に変換してから計算します。
ticket-numbers 手続きは、四則演算して total になる ４つの数字をリストアップします。
早速実行してみましょう。処理系は Gauche を使用しますが、処理系依存の処理は一切無く、プログラム側で必要な手続きを用意しているので、Scheme であれば、どんな処理系であっても動作すると思います。
gosh> (define numbers (ticket-numbers 10)) numbers
総当り解法であるため、結構な処理時間がかかりますが、これでチケットナンバー問題で計算して１０になる４桁の数字が列挙できました。
毎回計算すると時間がかかるので、numbers に解答を入れておきます。numbers を print すれば解答が列挙されます。
さて、冒頭のお題をクリアするには、この４つの数字から計算方法を列挙する手続きが必要です。
(define (answer num-list total)
(let ((nums (permutations (lst->ulst num-list) 4)))
(filter (lambda (exp) (= (eval-rpn (exp->rpn exp)) total))
(flatmap ins-parentheses (flatmap (lambda (num) (build-exps operators num))
(map ulst->lst nums))))))
(define (answer2 num-list total)
(define ht (make-hash-table 'equal?))
(let ((nums (permutations (lst->ulst num-list) 4)))
(define (iter exp)
(if (null? exp)
(hash-table-keys ht)
(let ((key (analyze-rpn (exp->rpn (car exp)))))
(or (null? key) (hash-table-push! ht key (car exp)))
(iter (cdr exp)))))
(iter (filter (lambda (exp) (= (eval-rpn (exp->rpn exp)) total))
(flatmap ins-parentheses (flatmap (lambda (num) (build-exps operators num))
(map ulst->lst nums)))))))
(define (print-answer answer-proc num-list total)
(map print (answer-proc num-list total))
'done)answer 手続きが４桁の数字から計算式を生成します。ただし、同じ数字を入れ替えたケースや、交換法則できる加算・乗算によって、同じ計算式がたくさん出てきてしまいます。answer2 はそういった冗長な解答と排除する、より強化された answer 手続きです。さらに、リストそのままでは結果がとても見辛いため、適切に改行を入れる print-answer 手続きも導入します。
まず answer 手続きを使用してみます。numbers の中から適当な数字を選んでください。例では 8 8 8 9 を選びました。
gosh> (print-answer answer '(8 8 8 9) 10) ((8 + (8 * 9)) / 8) ((8 + (8 * 9)) / 8) ((8 + (9 * 8)) / 8) (((8 * 9) + 8) / 8) ((8 + (9 * 8)) / 8) (((8 * 9) + 8) / 8) ((8 + (8 * 9)) / 8) ((8 + (8 * 9)) / 8) ((8 + (9 * 8)) / 8) (((8 * 9) + 8) / 8) ((8 + (9 * 8)) / 8) (((8 * 9) + 8) / 8) ((8 + (8 * 9)) / 8) ((8 + (8 * 9)) / 8) ((8 + (9 * 8)) / 8) (((8 * 9) + 8) / 8) ((8 + (9 * 8)) / 8) (((8 * 9) + 8) / 8) (((9 * 8) + 8) / 8) (((9 * 8) + 8) / 8) (((9 * 8) + 8) / 8) (((9 * 8) + 8) / 8) (((9 * 8) + 8) / 8) (((9 * 8) + 8) / 8) done
このように冗長と思われる計算式を生成しますが、answer 手続きは確認用のために残してあります。
次に、より強化された answer2 手続きを使用してみます。
gosh> (print-answer answer2 '(8 8 8 9) 10) ((8 + (8 * 9)) / 8) done
このように answer2 手続きは、冗長な計算式を消去するので、１通りの計算式のみを解答します。
さて、以上を踏まえて、いよいよ本題の解答をしていきます。
(define (most-comb numbers)
(define (iter lst result)
(if (null? lst)
result
(iter (cdr lst)
(let* ((num (car lst))
(cnt (cdr result))
(ans (answer2 num 10))
(len (length ans)))
(if (> len cnt)
(cons num len)
result)))))
(iter numbers (cons nil 0)))
(define (comb-n numbers count)
(define (iter lst result)
(if (null? lst)
result
(iter (cdr lst)
(let* ((num (car lst))
(ans (answer2 num 10))
(len (length ans)))
(if (= len count)
(append result (cons num nil))
result)))))
(iter numbers nil))most-comb 手続きは、解答の候補となる４つの数字から計算式を生成して、もっとも出来上がる計算式が多いものを答えます。
comb-n 手続きは、計算式の数が n になるものを答えます。これは確認用（デバッグ用）の手続きです。
comb-n 手続きを使用して計算式が 2 通りになる４桁の数字を抽出してみます。
gosh> (comb-n numbers 2) ((6 8 8 9) (6 7 8 8) (6 7 7 9) (6 6 7 8) (5 8 8 9) (4 8 8 8) (3 3 3 9) (2 4 7 7) (2 2 9 9) (2 2 7 9) (2 2 2 2) (1 3 3 6) (1 2 8 8) (1 2 7 7) (1 1 6 8) (1 1 1 4))
1 1 6 8 を使って確認してみます。
gosh> (print-answer answer2 '(1 1 6 8) 10) (6 + (8 / (1 + 1))) ((8 * (1 + 1)) - 6) done
このように 2 つの計算式が求まります。
では本題に解答します。
gosh> (most-comb numbers) ((1 2 4 5) . 113)
結果は省略しますが、以下のようにすれば、計算式を列挙します。
gosh> (print-answer answer2 '(1 2 4 5) 10) (略) done
解答：
チケットナンバー問題において、もっとも多くの計算方法を持つ４桁の数字は、1 2 4 5 である。
計算式の数は 113 通りある。
以上です。
