Appendix 2. 関数電卓

1. 初めに

少しは実用的なプログラムの第２弾として、今回は関数電卓を取り上げます。関数電卓は、再帰と、手続きをデータとして扱えるという Scheme の特徴をいかすと簡潔に書くことができます。

このプログラムのミソは、演算子を名前、手続き、優先度をメンバーにもつ構造体として表現していることです。こうすることで、全ての演算を統一的に扱うことができます。

2. 電卓の仕様

ここで作成する電卓はいわゆる普通の電卓です。以下のように動作します。

浮動小数点の計算を繰り返し行う。つまり、１つの式に対する計算が済んだら、その結果を表示した後、プロンプトを表示して別の入力を受け付ける。
計算の順序は通常の中置記法の順序に従う。
入力式にたいする計算が行えない場合は、その旨を表示して次の式の入力を促す。(エラー終了しない)

3. 実装方法

入力された文字列をリストに変換し、それに対する計算を行います。

3.1. 演算子の構造体

構造体を使って演算子を表します。構造体に保持する項目は演算子の名前 (name)、関数 (fun)、優先度 (priority) です。数字が大きいほうが優先度が高く先に計算されます。

演算子	優先度	同じ優先度の計算順序	例
定数	6	左から	pi, e
階乗	5	左から	!
算術関数	4	右から	sin, log, exp
累乗	3	右から	^
単項の +/-	2	右から	+, -
乗除	1	左から	*,/,%
加減	0	左から	+, -

3.2. 文字列からリストへの変換方法

数をあらわす文字列は数に、演算子を表す文字列は対応する手続きと優先順位のリストに、定数は対応する数に変換されてリストに加えられます。'(', ')' がある場合は、カッコの中を再帰的にリストに変換します。

文字列の最初と最後にスペースがある場合はそれを取り除く。
文字列が空なら要素のリストを返す
文字列の最初が数をあらわす文字列の正規表現 ( /^[0-9]+(\.[0-9]+)?([eE][+-]?[0-9]+)?/ )と一致すれば、浮動小数点に変換して要素のリストに加える。
文字列が演算子を表す文字列で始まっていれば、その部分を演算子の構造体に変換してリストに加える。

例えば次のように変換されます。下の例で、<x> は演算子 x を表す構造体を表します。また、単項の +,- はそれぞれ @+, @- と表記します。

文字列	変換後のリスト
1+2	(1.0 <+> 2.0)
(2+3)*4	((2.0 <+> 3.0) <*> 4.0)
-2*sin(pi)	(<@-> 2.0 <*> <sin> <pi>)

3.3. 式を表すリストの評価方法

次のように計算していきます。

カッコの中から計算を行う
優先度の高い順に計算する
定数は、浮動小数点に変換する
階乗 (!) は、演算子の前の要素に作用させる
単項演算子は、演算子の次の要素に作用させる
二項演算子は、演算子の前の要素と後の要素に作用させる

こんな感じになります

(1.0 <+> 2.0) → 3.0
((2.0 <+>  3.0) <*>  4.0) → (5.0 <*>  4.0) → 20.0
(<@-> 2.0 <*> <sin> <pi>) 
    → (<@-> 2.0 <*> <sin> 3.14159265359)
    → (<@-> 2.0 <*>  -1.0)
    → (-2.0 <*> -1.0)
    → 2.0

4. MzScheme による実装

上の方針に従って MzScheme で実装したのが下のコード (calc.scm) です。 R⁶RS や SRFI を MzScheme 独自の実装と混在させると不具合が生ずるので、全て MzScheme 独自の実装で書いてあります。

[code 1] (calc.scm)

001:   ;; a simple calculator written in Scheme
002:   ;; by SHIDO, T.
003:   
004:   
005:   
006:   
007:   ;; regular expression of number
008:   (define RNUM (regexp "^[0-9]+(\\.[0-9]+)?([eE][+-]?[0-9]+)?"))
009:   
010:   ;; cc is the global escape. the initial value is display
011:   (define cc display)
012:   
013:   ;; defining the priority of operators
014:   (define P_CST 6)          ; constants
015:   (define P_LHB 5)          ; !
016:   (define P_FUN 4)          ; arithmetic functions 
017:   (define P_POW 3)          ; power
018:   (define P_UPM 2)          ; unary +, -
019:   (define P_MD  1)          ; *. /, %
020:   (define P_BPM 0)          ; binary +, -
021:   
022:   
023:   ;; the structure of operatos having name, fun and priority
024:   (define-struct operator (name fun priority))
025:                     
026:   
027:   (define (inc i) (+ 1 i))
028:   (define (dec i) (- i 1))
029:   
030:   (define (fact n)
031:     (if (= n 0) 1
032:       (let loop ((i 0) (m 1))
033:         (if (= i n) m
034:           (loop (inc i) (* m (inc i)))))))
035:   
036:   (define (permutation m n)
037:     (let loop((i 0) (k 1))
038:       (if (= i n)
039:           k
040:         (loop (inc i) (* k (- m i))))))
041:   
042:   (define (combination m n)
043:     (/ (permutation m n) (fact n)))
044:       
045:   
046:   ;; a list of the structure operator
047:   (define OPERATORS (map (lambda (tup)
048:                            (apply make-operator tup))
049:     `(("+" ,+ ,P_BPM) ("-" ,- ,P_BPM)
050:       ("@+" ,+ ,P_UPM) ("@-" ,- ,P_UPM)  ; @+ and @- represent unary +, -
051:       ("*" ,* ,P_MD) ("/" ,/ ,P_MD) ("%" ,modulo ,P_MD)
052:       ("**" ,expt ,P_POW) ("^" ,expt ,P_POW)
053:       ("exp" ,exp ,P_FUN) ("log" ,log ,P_FUN) ("sqrt" ,sqrt ,P_FUN) ("log10" ,(lambda (x) (/ (log x) (log 10.0))) ,P_FUN)
054:       ("sin" ,sin ,P_FUN) ("cos" ,cos ,P_FUN) ("tan" ,tan ,P_FUN) 
055:       ("asin" ,asin ,P_FUN) ("acos" ,acos ,P_FUN) ("atan" ,atan ,P_FUN)
056:       ("!" ,fact ,P_LHB) ("P" ,permutation ,P_POW) ("C" ,combination ,P_POW)
057:       ("<<" ,(lambda (x y) (* x (expt 2 y))) ,P_POW)
058:       (">>" ,(lambda (x y) (/ x (expt 2 y))) ,P_POW)
059:       ("pi"  ,(* 4.0 (atan 1.0)) ,P_CST) ("e"  ,(exp 1.0) ,P_CST))))          
060:   
061:   
062:   ;; a hash table of operators
063:   (define H_OP (make-hasheq))
064:   (for-each (lambda (op)
065:               (hash-set! H_OP  (string->symbol (operator-name op)) op))
066:             OPERATORS)
067:   
068:   
069:   
070:   (define L_OP (sort (map operator-name OPERATORS)
071:                      #:key string-length >))
072:   
073:   
074:   (define (list-ref-with-assert ls i)
075:     (if (<= 0 i (dec (length ls)))
076:         (list-ref ls i)
077:       (cc "Invarid formula!")))
078:     
079:   
080:   
081:   (define (print . ls0)
082:     (let loop((ls ls0))
083:       (if (null? ls)
084:           (newline)
085:         (begin
086:          (display (car ls))
087:          (display ", ")
088:          (loop (cdr ls))))))
089:   
090:   
091:   
092:   (define (alnum? c)
093:     (or (and (char<=? #\a c) (char<=? c #\z))
094:         (and (char<=? #\A c) (char<=? c #\Z))
095:         (and (char<=? #\0 c) (char<=? c #\9))))
096:   
097:   
098:   
099:   ;; it returns the position of the corresponding close parenthesis
100:   (define (search-close str)
101:     (let ((str (string-tail str 1)) (limit  (string-length str)))
102:       (let loop((i 0) (n 1))
103:         (cond
104:          ((= i limit) #f)                                       
105:          ((= n 0) i)
106:          (else (let ((c (string-ref str i)))
107:                  (cond
108:                   ((char=? c #\() (loop (inc i) (inc n)))
109:                   ((char=? c #\)) (loop (inc i) (dec n)))
110:                   (else (loop (inc i) n)))))))))
111:   
112:   
113:   
114:   
115:   
116:   
117:   (define (string->operator s0 ls0)
118:     (hash-ref H_OP
119:                    (string->symbol
120:                     (if (and
121:                          (or (string=? s0 "+") (string=? s0 "-"))
122:                          (or (null? ls0) (operator? (car ls0))))
123:                         (string-append "@" s0)
124:                       s0))
125:                     #f))
126:   
127:   
128:   
129:   (define (string-W? s)
130:     (let loop((ls (string->list s)))
131:       (cond
132:        ((null? ls) #t)
133:        ((alnum? (car ls)) #f)
134:        (else (loop (cdr ls))))))
135:         
136:   
137:   
138:   (define (char-sep? c)
139:     (case c (( #\space #\( ) #t) (else #f)))
140:   
141:   
142:   
143:   
144:   (define (find-op-idx s0)
145:     ;(print s0)
146:     (let loop((ls (filter  (lambda(x) (<= (string-length x) (string-length s0))) L_OP)))
147:       (if (null? ls) (cc "can not find operator")
148:         (let* ((sop (car ls))
149:                (len (string-length sop))
150:                (s1 (string-head s0 len))
151:                (op (hash-ref H_OP (string->symbol sop) #f)))
152:           (if (and (string=? sop s1)
153:                    (or (op-lhb? op) 
154:                        (op-constant? op)
155:                        (and (< len (string-length s0))
156:                             (or (string-W? sop) 
157:                                 (= (operator-priority op) P_POW)
158:                                 (char-sep? (string-ref s0 len))))))
159:               len
160:             (loop (cdr ls)))))))
161:   
162:   
163:   
164:   (define (get-op s ls)
165:     (hash-ref H_OP
166:                     (string->symbol
167:                      (if (and (or (string=? s "+") (string=? s "-"))
168:                               (or (null? ls) (operator? (car ls))))
169:                          (string-append "@" s) s))
170:                     #f))
171:   
172:   
173:   (define (list-head ls n)
174:     (letrec ((iter (lambda (ls0 ls1 i)
175:                      (if (or (= i n) (null? ls0))
176:                          (reverse ls1)
177:                        (iter (cdr ls0) (cons (car ls0) ls1) (inc i))))))
178:        (iter ls '() 0)))
179:   
180:   
181:   (define (match-end-index i mobj)
182:     (cdr (list-ref-with-assert mobj i)))
183:   
184:   (define (re-match-extract s mobj i)
185:     (let ((p (list-ref-with-assert mobj i)))
186:       (if p
187:           (substring s (car p) (cdr p))
188:         #f)))
189:   
190:   
191:   (define (string-head s pos)
192:     (substring s 0 pos))
193:   
194:   (define (string-tail s pos)
195:     (substring s pos (string-length s)))
196:   
197:   
198:   ;; it makes a list of numbers and operators from the given string and returns it.
199:   (define (read-input s0)
200:     (letrec ((iter (lambda (s0 ls0)
201:                      (let ((s (string-trim s0)))
202:                        ;(print s ls0)
203:                        (cond
204:                         ((= 0 (string-length s)) ; return the resulting list if the input string is finished
205:                          (reverse ls0))
206:                         ((char=? (string-ref s 0) #\()
207:                          (let ((pos (search-close s)))
208:                            (iter (string-tail s (inc pos)) (cons (iter (substring s 1 pos) '()) ls0))))
209:                         (else
210:                          (let ((mobj (regexp-match-positions RNUM s)))
211:                           ; (display mobj) (newline)
212:                            (if mobj
213:                                (iter (string-tail s (match-end-index 0 mobj))
214:                                      (cons (string->number (re-match-extract s mobj 0)) ls0))
215:                              (let ((pos (find-op-idx s)))
216:                                (let ((op (get-op (string-head s pos) ls0)))
217:                                  (iter (string-tail s pos) (cons op ls0))))))))))))
218:             (iter s0 '() )))
219:   
220:   
221:   
222:   (define (single? ls)
223:     (and
224:      (list? ls)
225:      (not (null? ls))
226:      (null? (cdr ls))))
227:   
228:   
229:   
230:   ;; it returns the position of the next operator to apply.
231:   (define (find-op ls0 priority)
232:     (let loop((ls (if (memv priority priority-reverse) (reverse ls0) ls0)) (j 0))
233:       (cond
234:        ((null? ls) #f)
235:        ((and (op-pair? (car ls)) (= (second (car ls)) priority)) 
236:         (if (memv priority priority-reverse)
237:             (- (length ls0) j 1)
238:             j))
239:        (else   (loop (cdr ls) (inc j))))))
240:   
241:   
242:   
243:   (define (op-unary? op)
244:     (let ((p (operator-priority op)))
245:       (or (= p P_FUN) (= p P_UPM))))
246:   
247:   
248:   
249:   (define (op-lhb? op)
250:     (= (operator-priority op) P_LHB))
251:   
252:   
253:   
254:   (define (op-constant? op)
255:     (= (operator-priority op) P_CST))
256:   
257:   
258:   
259:   (define (op-binary? op)
260:     (let ((p (operator-priority op)))
261:       (or (= p P_BPM) (= p P_MD) (= p P_POW))))
262:   
263:   
264:   
265:   (define (op-reverse? op)
266:     (let ((p (operator-priority op)))
267:       (or (= p P_FUN) (= p P_POW) (= p P_UPM))))
268:   
269:   
270:   
271:   (define (op>? op1 op2)
272:     (or
273:      (not (operator? op2))
274:      ((if (op-reverse? op1) >= > ) (operator-priority op1) (operator-priority op2))))
275:   
276:   
277:   
278:   (define (find-op-pos ls0)
279:     (let loop((i 0) (pos -1) (ls ls0) (op0 #f))
280:       (if (null? ls)
281:           pos
282:         (let* ((op (car ls))
283:                (update (and (operator? op) (op>? op op0))))
284:           (loop (inc i) (if update i pos) (cdr ls) (if update op op0))))))
285:   
286:   
287:   
288:   ;; it returns a number by calculating a list of numbers and operators
289:   (define (calc-list ls)
290:     (cond
291:      ((number? ls) ls)
292:      ((single? ls) (calc-list (car ls)))
293:      ((list? ls)
294:       (let* ((pos (find-op-pos ls)) (op (list-ref-with-assert ls pos)))
295:         (calc-list
296:          (append (list-head ls (- pos (if (or (op-lhb? op) (op-binary? op)) 1 0)))
297:                  (cons
298:                   (let ((fun (operator-fun op)))
299:                     (cond
300:                      ((op-constant? op) fun)
301:                      ((op-lhb? op)   (fun (calc-list (list-ref-with-assert ls (dec pos)))))
302:                      ((op-unary? op) (fun (calc-list (list-ref-with-assert ls (inc pos)))))
303:                      ((op-binary? op) (fun (calc-list (list-ref-with-assert ls (dec pos))) (calc-list (list-ref-with-assert ls (inc pos)))))
304:                      (else (cc "funny!"))))
305:                   (list-tail ls (+ pos (if (or (op-unary? op) (op-binary? op)) 2 1))))))))
306:      (else (cc "Invarid formula!"))))
307:   
308:   
309:   
310:   
311:   
312:   (define (string-null? s)
313:     (= 0 (string-length s)))
314:   
315:   
316:   (define (list-trim ls)
317:     (let loop((ls ls))
318:       (cond
319:        ((null? ls) '())
320:        ((char=? (car ls) #\space) (loop (cdr ls)))
321:        (else  ls))))
322:   
323:   
324:   (define (string-trim s)
325:     (list->string
326:      (reverse
327:       (list-trim
328:        (reverse (list-trim (string->list s)))))))
329:   
330:   
331:   
332:   
333:   
334:   (define (calc)
335:     (let loop()
336:       (display "> ")
337:       (let ((str (begin (read-line)   ;to absorb a funny behavior of mzscheme input
338:                         (read-line (current-input-port) 'any-one))))  
339:         (if (string-null? str)
340:             'bye
341:           (begin
342:            (display 
343:             (call-with-current-continuation
344:              (lambda (k)
345:                (set! cc k)           ; re-entry point in case of exception
346:                (calc-list (read-input str)))))
347:            (newline)
348:            (loop))))))
349:

注

  `(("+" ,+ ,P_BPM) ("-" ,- ,P_BPM) ...................)

は

  (list (list "+" + P_BPM) (list "-" - P_BPM) ...................)

の省略記法。詳しくはここをみてください。
文字列を読み込んでリストに変換するときに、名前、手続き、および優先順位を保持した構造体で演算子をあらわすと、プログラムのコード上で明示的に演算を扱う必要がなくなり、プログラムが簡潔になります。また、演算子の追加も容易にできます。

5. 使い方

MzScheme を立ち上げて、calc.scm calc.scm をロードします。その後コンソールから (calc) と入力します。終了するときは何も入力しないでリターンします。
プロンプトから式を入力すると計算結果が表示されます。

> (load/cd "calc.scm")
> (calc)
> (1+2)*(15-3)
36
>
bye

6. 終わりに

N Queen と同様、電卓プログラムも簡潔に書くことができます。

電卓プログラムは、

自然に再帰関数を使うことができる
手続きをデータとして扱うことができる。

という Scheme の長所を生かすことができます。