チケットナンバー問題の回答の最適化 バグ修正

以前に掲載したチケットナンバー問題の回答の最適化がバグってましたｗ

その１
リストの比較処理が手抜きすぎ。エラーで落ちる。

gosh> (answer3 '(3 3 3 3) 10)
*** ERROR: real number required: *
Stack Trace:
_______________________________________
  0  (< (car l1) (car l2))
        at "/cygdrive/d/srcs/scheme/src/ticket-numbers-1.scm":249
  1  (list<=? v1 v2)
        at "/cygdrive/d/srcs/scheme/src/ticket-numbers-1.scm":268
  2  (sort-rpn (pop) e addend)
        at "/cygdrive/d/srcs/scheme/src/ticket-numbers-1.scm":278
  3  (push (sort-rpn (pop) e addend))
        at "/cygdrive/d/srcs/scheme/src/ticket-numbers-1.scm":278
  4  (analyze-rpn (exp->rpn (car exp)))
        at "/cygdrive/d/srcs/scheme/src/ticket-numbers-1.scm":300
  5  (eval expr env)
        at "/usr/local/share/gauche-0.9/0.9.5/lib/gauche/interactive.scm":282

直す！

(define (list<=? lst1 lst2)
  (define operators-order '(+ - * /))
  (define (iter l1 l2)
    (cond ((null? l1) #t)
          ((and (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)))))

その2
あと、0 で除算するケースで頑張りすぎ。エラーにならないけども結果が変。

gosh> (answer3 '(4 6 0 3) 10)
(4 - (0 - 6))
(6 + (0 + 4))
(4 + (6 - 0))
(4 - ((0 / 3) - 6))
(6 - (0 - 4))
(6 - ((0 / 3) - 4))
(4 + (6 + (0 / 3)))
((4 + 6) - (0 * 3))
(6 + (4 - (0 * 3)))
((4 + 6) - 0)
(4 + (6 + (0 * 3)))
(4 + (6 - (0 / 3)))
((4 + 6) - (0 / 3))
(6 + (4 - 0))
((0 / 3) + (4 + 6))
(6 + (4 + (0 / 3)))
(4 - ((0 * 3) - 6))
(4 + (6 - (0 * 3)))
(6 - ((0 * 3) - 4))
(4 + (0 + 6))
(6 + (4 - (0 / 3)))
(6 + (4 + (0 * 3)))
((0 * 3) + (4 + 6))
(0 + (4 + 6))
done

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 (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 (= 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)))

再テスト。

gosh> (answer3 '(3 3 3 3) 10)
((3 * 3) + (3 / 3))
done
gosh> (answer3 '(4 6 0 3) 10)
(4 - ((0 / 3) - 6))
(6 - ((0 / 3) - 4))
(4 + (6 + (0 / 3)))
((4 + 6) - (0 * 3))
(6 + (4 - (0 * 3)))
(4 + (6 + (0 * 3)))
(4 + (6 - (0 / 3)))
((4 + 6) - (0 / 3))
((0 / 3) + (4 + 6))
(6 + (4 + (0 / 3)))
(4 - ((0 * 3) - 6))
(4 + (6 - (0 * 3)))
(6 - ((0 * 3) - 4))
(6 + (4 - (0 / 3)))
(6 + (4 + (0 * 3)))
((0 * 3) + (4 + 6))
done

直った。たぶん。
以下に全ソースを載せます。

;; -*- coding: utf-8 -*-

(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))))

;;
(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 (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)))

;;stack
(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))

;;RPN
(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 (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))

;;

(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))

;;

(define (list<=? lst1 lst2)
  (define operators-order '(+ - * /))
  (define (iter l1 l2)
    (cond ((null? l1) #t)
          ((and (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 (= 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 (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)
          (let ((key (analyze-rpn (exp->rpn (car exp)))))
            (and (not (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)))))))

このソースをコピペして拡張子 scm で保存して、Gauche に食わせれば動きます。
Gauche 以外の Scheme 処理系でも動きます。たぶん。処理系依存のコードは書いていません。
今日から Scheme やってみようかなー、という人を応援します。

完全な動作するコードを掲載することｂ

これがこのブログのポリシーです。