たまにはプログラミングの日記を書きますかね。ぜんぜん書いてないので。
まず以前に書いたチケットナンバー問題のプログラムです。
チケットナンバー問題の細かい仕様はググってください。
言語は Scheme、開発環境は、Emacs + Gauche です。
(define nil '()) (define true #t) (define false #f) (define debugging true) (define (debug-on) (set! debugging true) true) (define (debug-off) (set! debugging false) false) (define (debug-print . msg) (define (debug-print-iter m) (cond ((null? m) (newline)) (else (display (car m)) (display " ") (debug-print-iter (cdr m))))) (if debugging (begin (display ";*** DEBUG *** ") (debug-print-iter msg)))) ;;permutation procedures (define (enumerate-interval low high) (if (> low high) nil (cons low (enumerate-interval (+ low 1) high)))) (define (filter predicate sequence) (cond ((null? sequence) nil) ((predicate (car sequence)) (cons (car sequence) (filter predicate (cdr sequence)))) (else (filter predicate (cdr sequence))))) (define (accumulate op initial sequence) (if (null? sequence) initial (op (car sequence) (accumulate op initial (cdr sequence))))) (define (flatmap proc seq) (accumulate append nil (map proc seq))) (define (remove item sequence) (filter (lambda (x) (not (eq? x item))) sequence)) (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))) ;;stack procedures (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)) ;;reverse polish notation's procedures (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) (push 0) (push (/ (pop) divisor))))) (else (push e))) (iter (cdr r))))) (init-stack) (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 (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 (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 (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))
このプログラムを実行すると、
gosh> (ticket-numbers 10) ((9 9 9 9) (8 9 9 9) (8 8 8 9) (8 8 8 8) (7 8 9 9) (7 8 8 9) (7 7 7 9) (7 7 7 8) (6 8 8 9) (6 7 9 9) (6 7 8 9) (6 7 8 8) (6 7 7 9) (6 6 9 9) (6 6 8 9) (6 6 8 8) (6 6 7 9) (6 6 7 8) (6 6 6 9) (6 6 6 8) (5 9 9 9) (5 8 8 9) (5 8 8 8) (5 7 8 9) (5 7 7 9) (5 7 7 8) (5 7 7 7) (5 6 9 9) (5 6 8 9) (5 6 8 8) (5 6 7 9) (5 6 7 8) (5 6 7 7) (5 6 6 9) (5 6 6 7) (5 6 6 6) (5 5 9 9) (5 5 8 9) (5 5 8 8) (5 5 7 9) (5 5 7 8) (5 5 7 7) (5 5 6 9) (5 5 6 8) (5 5 6 7) (5 5 6 6) (5 5 5 9) (5 5 5 8) (5 5 5 7) (5 5 5 6) (5 5 5 5) (4 8 8 9) (4 8 8 8) (4 7 9 9) (4 7 8 9) (4 7 8 8) (4 7 7 9) (4 7 7 8) (4 7 7 7) (4 6 9 9) (4 6 8 9) (4 6 8 8) (4 6 7 9) (4 6 7 8) (4 6 7 7) (4 6 6 9) (4 6 6 8) (4 6 6 7) (4 6 6 6) (4 5 9 9) (4 5 8 9) (4 5 8 8) (4 5 7 9) (4 5 7 8) (4 5 7 7) (4 5 6 9) (4 5 6 8) (4 5 6 7) (4 5 6 6) (4 5 5 9) (4 5 5 7) (4 5 5 6) (4 5 5 5) (4 4 9 9) (4 4 8 9) (4 4 8 8) (4 4 7 9) (4 4 7 8) (4 4 6 9) (4 4 6 8) (4 4 6 7) (4 4 6 6) (4 4 5 8) (4 4 5 7) (4 4 5 6) (4 4 5 5) (4 4 4 9) (4 4 4 8) (4 4 4 7) (4 4 4 6) (4 4 4 5) (3 8 9 9) (3 8 8 9) (3 8 8 8) (3 7 9 9) (3 7 8 9) (3 7 8 8) (3 7 7 8) (3 7 7 7) (3 6 9 9) (3 6 8 9) (3 6 8 8) (3 6 7 9) (3 6 7 8) (3 6 7 7) (3 6 6 8) (3 6 6 7) (3 6 6 6) (3 5 9 9) (3 5 8 9) (3 5 8 8) (3 5 7 9) (3 5 7 8) (3 5 7 7) (3 5 6 9) (3 5 6 8) (3 5 6 7) (3 5 6 6) (3 5 5 9) (3 5 5 8) (3 5 5 7) (3 5 5 6) (3 5 5 5) (3 4 9 9) (3 4 8 9) (3 4 8 8) (3 4 7 9) (3 4 7 8) (3 4 7 7) (3 4 6 9) (3 4 6 8) (3 4 6 7) (3 4 6 6) (3 4 5 9) (3 4 5 8) (3 4 5 7) (3 4 5 6) (3 4 5 5) (3 4 4 9) (3 4 4 8) (3 4 4 7) (3 4 4 6) (3 4 4 5) (3 3 9 9) (3 3 8 9) (3 3 8 8) (3 3 7 9) (3 3 7 8) (3 3 7 7) (3 3 6 9) (3 3 6 8) (3 3 6 7) (3 3 6 6) (3 3 5 9) (3 3 5 8) (3 3 5 7) (3 3 5 6) (3 3 5 5) (3 3 4 9) (3 3 4 8) (3 3 4 7) (3 3 4 6) (3 3 4 5) (3 3 4 4) (3 3 3 9) (3 3 3 8) (3 3 3 7) (3 3 3 6) (3 3 3 5) (3 3 3 4) (3 3 3 3) (2 9 9 9) (2 8 9 9) (2 8 8 9) (2 8 8 8) (2 7 9 9) (2 7 8 9) (2 7 8 8) (2 7 7 9) (2 7 7 8) (2 7 7 7) (2 6 9 9) (2 6 8 9) (2 6 8 8) (2 6 7 9) (2 6 7 8) (2 6 7 7) (2 6 6 9) (2 6 6 8) (2 6 6 7) (2 6 6 6) (2 5 9 9) (2 5 8 9) (2 5 8 8) (2 5 7 9) (2 5 7 8) (2 5 7 7) (2 5 6 9) (2 5 6 8) (2 5 6 7) (2 5 6 6) (2 5 5 9) (2 5 5 8) (2 5 5 7) (2 5 5 6) (2 5 5 5) (2 4 9 9) (2 4 8 9) (2 4 8 8) (2 4 7 9) (2 4 7 8) (2 4 7 7) (2 4 6 9) (2 4 6 8) (2 4 6 7) (2 4 6 6) (2 4 5 9) (2 4 5 8) (2 4 5 7) (2 4 5 6) (2 4 5 5) (2 4 4 9) (2 4 4 8) (2 4 4 7) (2 4 4 6) (2 4 4 5) (2 4 4 4) (2 3 9 9) (2 3 8 9) (2 3 8 8) (2 3 7 9) (2 3 7 8) (2 3 7 7) (2 3 6 9) (2 3 6 8) (2 3 6 7) (2 3 6 6) (2 3 5 9) (2 3 5 8) (2 3 5 7) (2 3 5 6) (2 3 5 5) (2 3 4 9) (2 3 4 8) (2 3 4 7) (2 3 4 6) (2 3 4 5) (2 3 4 4) (2 3 3 9) (2 3 3 8) (2 3 3 7) (2 3 3 6) (2 3 3 5) (2 3 3 4) (2 3 3 3) (2 2 9 9) (2 2 8 9) (2 2 8 8) (2 2 7 9) (2 2 7 8) (2 2 7 7) (2 2 6 9) (2 2 6 8) (2 2 6 7) (2 2 6 6) (2 2 5 9) (2 2 5 8) (2 2 5 6) (2 2 5 5) (2 2 4 9) (2 2 4 8) (2 2 4 7) (2 2 4 6) (2 2 4 5) (2 2 4 4) (2 2 3 9) (2 2 3 8) (2 2 3 7) (2 2 3 6) (2 2 3 5) (2 2 3 4) (2 2 3 3) (2 2 2 9) (2 2 2 8) (2 2 2 7) (2 2 2 6) (2 2 2 5) (2 2 2 4) (2 2 2 3) (2 2 2 2) (1 9 9 9) (1 8 9 9) (1 8 8 9) (1 8 8 8) (1 7 9 9) (1 7 8 9) (1 7 8 8) (1 7 7 9) (1 7 7 8) (1 6 8 9) (1 6 8 8) (1 6 7 9) (1 6 7 8) (1 6 6 9) (1 6 6 8) (1 5 9 9) (1 5 8 9) (1 5 8 8) (1 5 7 9) (1 5 7 8) (1 5 7 7) (1 5 6 9) (1 5 6 8) (1 5 6 7) (1 5 6 6) (1 5 5 9) (1 5 5 8) (1 5 5 7) (1 5 5 6) (1 5 5 5) (1 4 8 9) (1 4 8 8) (1 4 7 9) (1 4 7 8) (1 4 7 7) (1 4 6 9) (1 4 6 8) (1 4 6 7) (1 4 6 6) (1 4 5 9) (1 4 5 8) (1 4 5 7) (1 4 5 6) (1 4 5 5) (1 4 4 9) (1 4 4 8) (1 4 4 7) (1 4 4 6) (1 4 4 5) (1 3 8 9) (1 3 8 8) (1 3 7 9) (1 3 7 8) (1 3 7 7) (1 3 6 9) (1 3 6 8) (1 3 6 7) (1 3 6 6) (1 3 5 9) (1 3 5 8) (1 3 5 7) (1 3 5 6) (1 3 5 5) (1 3 4 9) (1 3 4 8) (1 3 4 7) (1 3 4 6) (1 3 4 5) (1 3 4 4) (1 3 3 9) (1 3 3 8) (1 3 3 7) (1 3 3 6) (1 3 3 5) (1 3 3 4) (1 3 3 3) (1 2 9 9) (1 2 8 9) (1 2 8 8) (1 2 7 9) (1 2 7 8) (1 2 7 7) (1 2 6 9) (1 2 6 8) (1 2 6 7) (1 2 6 6) (1 2 5 9) (1 2 5 8) (1 2 5 7) (1 2 5 6) (1 2 5 5) (1 2 4 9) (1 2 4 8) (1 2 4 7) (1 2 4 6) (1 2 4 5) (1 2 4 4) (1 2 3 9) (1 2 3 8) (1 2 3 7) (1 2 3 6) (1 2 3 5) (1 2 3 4) (1 2 3 3) (1 2 2 9) (1 2 2 8) (1 2 2 7) (1 2 2 6) (1 2 2 5) (1 2 2 4) (1 2 2 3) (1 2 2 2) (1 1 9 9) (1 1 8 9) (1 1 6 8) (1 1 6 7) (1 1 6 6) (1 1 5 8) (1 1 5 7) (1 1 5 6) (1 1 5 5) (1 1 4 9) (1 1 4 8) (1 1 4 7) (1 1 4 6) (1 1 4 5) (1 1 4 4) (1 1 3 9) (1 1 3 8) (1 1 3 7) (1 1 3 6) (1 1 3 5) (1 1 3 4) (1 1 3 3) (1 1 2 9) (1 1 2 8) (1 1 2 7) (1 1 2 6) (1 1 2 5) (1 1 2 4) (1 1 2 3) (1 1 1 9) (1 1 1 8) (1 1 1 7) (1 1 1 6) (1 1 1 5) (1 1 1 4) (0 9 9 9) (0 8 9 9) (0 8 8 9) (0 7 8 9) (0 7 7 9) (0 6 8 8) (0 6 7 9) (0 6 6 9) (0 5 7 9) (0 5 7 8) (0 5 6 9) (0 5 6 8) (0 5 5 9) (0 5 5 8) (0 5 5 7) (0 5 5 6) (0 5 5 5) (0 4 8 8) (0 4 7 7) (0 4 6 9) (0 4 6 8) (0 4 6 7) (0 4 6 6) (0 4 5 9) (0 4 5 8) (0 4 5 6) (0 4 5 5) (0 4 4 9) (0 4 4 6) (0 3 7 9) (0 3 7 8) (0 3 7 7) (0 3 6 8) (0 3 6 7) (0 3 5 8) (0 3 5 7) (0 3 5 6) (0 3 5 5) (0 3 4 9) (0 3 4 7) (0 3 4 6) (0 3 3 9) (0 3 3 7) (0 3 3 4) (0 2 8 9) (0 2 8 8) (0 2 7 8) (0 2 6 8) (0 2 6 7) (0 2 6 6) (0 2 5 9) (0 2 5 8) (0 2 5 7) (0 2 5 6) (0 2 5 5) (0 2 4 9) (0 2 4 8) (0 2 4 7) (0 2 4 6) (0 2 4 5) (0 2 4 4) (0 2 3 9) (0 2 3 8) (0 2 3 7) (0 2 3 5) (0 2 3 4) (0 2 2 9) (0 2 2 8) (0 2 2 7) (0 2 2 6) (0 2 2 5) (0 2 2 4) (0 2 2 3) (0 1 9 9) (0 1 8 9) (0 1 7 9) (0 1 6 9) (0 1 5 9) (0 1 5 6) (0 1 5 5) (0 1 4 9) (0 1 4 7) (0 1 4 6) (0 1 4 5) (0 1 3 9) (0 1 3 8) (0 1 3 7) (0 1 3 6) (0 1 3 5) (0 1 3 3) (0 1 2 9) (0 1 2 8) (0 1 2 7) (0 1 2 6) (0 1 2 5) (0 1 2 4) (0 1 1 9) (0 1 1 8) (0 1 1 5) (0 0 5 5) (0 0 4 6) (0 0 3 7) (0 0 2 8) (0 0 2 5) (0 0 1 9))
このように答えとなる 4 桁の数字をリストアップしてくれます。
ただ、とても見辛いのと、例えば、3 4 6 7 の 4 つ数字からどう計算したら 10 になるのかさっぱりわからないですね。
そこで、答えを作るコードを書きました。
(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)
(let ((nums (permutations (lst->ulst num-list) 4)))
(map print
(filter (lambda (exp) (= (eval-rpn (exp->rpn exp)) total))
(flatmap ins-parentheses (flatmap (lambda (num) (build-exps operators num)) (map ulst->lst nums)))))
'done))手続きが 2 つあるのは、見栄えの違いだけで同じです。answer2 の方が見易いのです。こっちを評価してみます。
gosh> (answer2 '(3 4 6 7) 10) ((4 - (7 / 3)) * 6) ((4 * (7 - 3)) - 6) ((4 * 7) - (3 * 6)) ((4 * 7) - (6 * 3)) (((6 / 3) * 7) - 4) ((6 / (3 / 7)) - 4) (6 * (4 - (7 / 3))) (((6 * 7) / 3) - 4) ((6 * (7 / 3)) - 4) (((7 - 3) * 4) - 6) (((7 / 3) * 6) - 4) ((7 / (3 / 6)) - 4) ((7 * 4) - (3 * 6)) ((7 * 4) - (6 * 3)) (((7 * 6) / 3) - 4) ((7 * (6 / 3)) - 4) done
このように、計算式込みの回答を表示してくれます。
ただし、回答が重複していてイマイチです。例えばこの 2 つです。
((7 * 4) - (3 * 6)) ((7 * 4) - (6 * 3))
加算と乗算は交換可能なので、この 2 つの計算式を別解とするのはちょっと違和感がありますね。
算数で習う交換法則というやつです。
A + B = B + A A * B = B * A
ちなみに、減算と除算は交換法則は使えません。
なので、さらにこれもなんとかしたいので、さらにコードを書きます。
(define (list<=? lst1 lst2)
(define (iter l1 l2)
(cond ((null? l1) #t)
((< (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))
(push 0)
(push (list (pop) e divisor)))))
(else (push e)))
(iter (cdr r)))))
(init-stack)
(iter rpn))
(define (answer3 num-list total)
(define ht (make-hash-table 'equal?))
(let ((nums (permutations (lst->ulst num-list) 4)))
(define (iter exp)
(if (null? exp)
(begin
(map print (hash-table-keys ht))
'done)
(begin
(hash-table-push! ht (analyze-rpn (exp->rpn (car exp))) (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)))))))逆ポーランド記法を計算する処理に少し手を加えて、交換法則で同一の計算式を無視するようにしました。
answer3 を評価してみます。
gosh> (answer3 '(3 4 6 7) 10) (((6 * 7) / 3) - 4) ((4 * 7) - (3 * 6)) ((4 * (7 - 3)) - 6) ((6 * (7 / 3)) - 4) ((6 / (3 / 7)) - 4) ((7 * (6 / 3)) - 4) ((7 / (3 / 6)) - 4) (6 * (4 - (7 / 3))) done
交換法則で同一とみなせる計算式を省くことができました。
4 桁の数字 3 4 6 7 を四則演算を使って 10 にする計算式は、 8 通りあることがわかります。(交換法則で重複する計算式は除く)
((4 * 7) - (3 * 6))
は頭で計算して結構すぐ見つけられましたが、一番最後にある計算式
(6 * (4 - (7 / 3)))
などの分数を使うものは、なかなか頭で考えるだけでは思い付けませんね。
残る課題は、分数の逆数で乗算と除算を入れ替えてるパターンです。
((7 * (6 / 3)) - 4) ((7 / (3 / 6)) - 4)
こういうのとかですが。これは難しそうですが暇な時にまた考えますｗ
