Simple Scheme で電卓をつくってみる(9) ―掛け算させてみる―

Simple Schemeで電卓を作っています。
掛け算を組み込みましょう。

多倍長計算します。8桁程度なら64ビット整数どうしでも桁溢れすることなく計算できますが、12桁くらいまでは対応できるようにしたいのと、表示まで考えると整数型は却ってややこしくなる部分があったりするので。
しかし片方だけは64ビット整数にしましょう。そうすれば主要な計算はmapを1回適用するだけで終了します。*1

(define-struct num (sign i f)) (define plus "") (define minus "-")
(define (num->list x) (append (num-i x) (num-f x)))
(define (num->int x) (foldl (lambda (n i) (+ n (* 10 i))) 0 (num->list x)))
(define (mul x y)
  (let ((xs (num->list x)) (y (num->int y)))
    (map (lambda (x) (* x y)) xs)))
"14175×256"
(mul (make-num plus '(1 4 1 7 5) '()) (make-num plus '(2 5 6) '()))

f:id:brv00:20191119201844j:plain:w250

もちろんこの計算結果はこのままでは表示できません。繰り上がり処理が必要です。lopで繰り上がり処理を行っていたのでそこからそのための関数（norm）を抽出しましょう。

(define (i/% x y)
  (let ((q (/ x y)) (r (% x y))) (if (< r 0) (list (-- q) (+ r y)) (list q r))))
(define (norm xs) (foldr (lambda (x ds) (append (i/% (+ x (car ds)) 10) (cdr ds))) '(0) xs))

; (define (lop op xs ys) (norm (map2 op xs ys)))

(define (mul x y)
  (let ((xs (num->list x)) (y (num->int y)))
    (norm (map (lambda (x) (* x y)) xs))))

これを上のコードのmulの呼び出しのすぐ手前のところに貼り付けて実行するとこうなります。

f:id:brv00:20191119202332j:plain:w250

ほぼ表示可能な形式ですが、先頭が10以上になっていますね。
さて、norm関数は、dsの、各段階での先頭要素に対して（未処理部分の末尾を足して）ひと桁分の繰り上がり処理*2を行う、ということを繰り返しています。
この、「ひと桁分の繰り上がり処理を行う」関数をnormから抽出して別関数にしましょう。

(define (carry x ds) (append (i/% (+ x (car ds)) 10) (cdr ds)))
(define (norm xs) (foldr carry '(0) xs))

このcarryを、上記のnormの結果に対して、最上位桁が0になるまで*3繰り返し適用すれば繰り上がり処理は完了します。

(define (mul x y)
  (let ((xs (num->list x)) (y (num->int y)))
    (letrec ((lp (lambda (xs) (if (= 0 (car xs)) (cdr xs) (lp (carry 0 xs))))))
      (lp (norm (map (lambda (x) (* x y)) xs))))))

f:id:brv00:20191119202640j:plain:w250

あとは、符号を決定し、整数部分と小数部分に分けて全体の桁数がmax-ndigits以下になるように調整すれば掛け算は完成です。ただし整数部分の桁数がmax-ndigitsを越えても調整は小数部分に対してのみ行います*4。整数部分の桁数がmax-ndigitsを越えたときの桁数の情報がエラー処理に必要になるからです。

(define (mul-signs-of x y) (if (string=? (num-sign x) (num-sign y)) plus minus))

(define (mul x y)
  (let ((xs (num->list x)) (y (num->int y))
        (sign (mul-signs-of x y)) (lf (+ (length (num-f x)) (length (num-f y)))))
    (letrec ((lp (lambda (xs) (if (= 0 (car xs)) (cdr xs) (lp (carry 0 xs))))))
      (let* ((xs (lp (norm (map (lambda (x) (* x y)) xs))))
             (xs (append (get-padding xs (++ lf)) xs)) (li (- (length xs) lf)))
        (make-num sign (take xs li)
                  (rdrop0s (drop (take xs max-ndigits) (min max-ndigits li))))))))