HOME

A-1. N Queen

もうひとつの Scheme 入門

A-3. 継続についてもう少し

download

書き込む

Appendix 2. 関数電卓

1. 初めに

このプログラムのミソは、演算子を ([手続き] 優先度) のリストとして表現していることです。 こうすることで、全ての演算を統一的に扱うことができます。

2. 電卓の仕様

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

3. 実装方法

3.1. 演算子の構造体

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

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

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

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

(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. MIT-Scheme による実装

[code 1] (calc.scm)

001:   ;; a simple calculator written in Scheme
002:   ;; by SHIDO, T.
003:   
004:   ;; use the regular-expression module
005:   (load-option 'regular-expression)
006:   
007:   ;; regular expression of number
008:   (define RNUM (re-compile-pattern "^[0-9]+\\(\\.[0-9]+\\)?\\([eE][+-]?[0-9]+\\)?" #f))
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-structure (operator keyword-constructor)
025:                     name fun priority)
026:   
027:   
028:   (define (fact n)
029:     (if (= n 0) 1
030:       (let loop ((i 0) (m 1))
031:         (if (= i n) m
032:           (loop (1+ i) (* m (1+ i)))))))
033:   
034:   (define (permutation m n)
035:     (let loop((i 0) (k 1))
036:       (if (= i n)
037:           k
038:         (loop (1+ i) (* k (- m i))))))
039:   
040:   (define (combination m n)
041:     (/ (permutation m n) (fact n)))
042:       
043:   
044:   ;; a list of the structure operator
045:   (define OPERATORS (map (lambda (tup)
046:                            (make-operator
047:                             'name (first tup)
048:                             'fun (second tup)
049:                             'priority (third tup)))
050:     `(("+" ,+ ,P_BPM) ("-" ,- ,P_BPM)
051:       ("@+" ,+ ,P_UPM) ("@-" ,- ,P_UPM)  ; @+ and @- represent unary +, -
052:       ("*" ,* ,P_MD) ("/" ,/ ,P_MD) ("%" ,modulo ,P_MD)
053:       ("**" ,expt ,P_POW) ("^" ,expt ,P_POW)
054:       ("exp" ,exp ,P_FUN) ("log" ,log ,P_FUN) ("sqrt" ,sqrt ,P_FUN) ("log10" ,(lambda (x) (/ (log x) (log 10.0))) ,P_FUN)
055:       ("sin" ,sin ,P_FUN) ("cos" ,cos ,P_FUN) ("tan" ,tan ,P_FUN) 
056:       ("asin" ,asin ,P_FUN) ("acos" ,acos ,P_FUN) ("atan" ,atan ,P_FUN)
057:       ("!" ,fact ,P_LHB) ("P" ,permutation ,P_POW) ("C" ,combination ,P_POW)
058:       ("<<" ,(lambda (x y) (* x (expt 2 y))) ,P_POW)
059:       (">>" ,(lambda (x y) (/ x (expt 2 y))) ,P_POW)
060:       ("pi"  ,(* 4.0 (atan 1.0)) ,P_CST) ("e"  ,(exp 1.0) ,P_CST))))          
061:   
062:   
063:   ;; a hash table of operators
064:   (define H_OP (make-string-hash-table))
065:   (for-each (lambda (op)
066:               (hash-table/put! H_OP  (operator-name op) op))
067:             OPERATORS)
068:   
069:   
070:   
071:   (define L_OP (sort (map operator-name OPERATORS) (lambda (a b) (> (string-length a) (string-length b)))))
072:   
073:   
074:   
075:   (define (print . ls0)
076:     (let loop((ls ls0))
077:       (if (null? ls)
078:           (newline)
079:         (begin
080:          (display (car ls))
081:          (display ", ")
082:          (loop (cdr ls))))))
083:   
084:   
085:   
086:   (define (alnum? c)
087:     (or (and (char<=? #\a c) (char<=? c #\z))
088:         (and (char<=? #\A c) (char<=? c #\Z))
089:         (and (char<=? #\0 c) (char<=? c #\9))))
090:   
091:   
092:   
093:   ;; it returns the position of the corresponding close parenthesis
094:   (define (search-close str)
095:     (let ((str (string-tail str 1)) (limit  (string-length str)))
096:       (let loop((i 0) (n 1))
097:         (cond
098:          ((= i limit) #f)                                       
099:          ((= n 0) i)
100:          (else (let ((c (string-ref str i)))
101:                  (cond
102:                   ((char=? c #\() (loop (1+ i) (1+ n)))
103:                   ((char=? c #\)) (loop (1+ i) (-1+ n)))
104:                   (else (loop (1+ i) n)))))))))
105:   
106:   
107:   
108:   ;; it returns the index of the matched group 
109:   (define (match-group mobj)
110:     (let loop((ls0 '(1 2 5) ))
111:       (if (null? ls0) #f
112:         (let ((i (car ls0)))
113:           (if (re-match-end-index i mobj) i
114:             (loop (cdr ls0)))))))
115:   
116:   
117:   
118:   (define (string->operator s0 ls0)
119:     (hash-table/get H_OP
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:   (define (char-sep? c)
138:     (case c (( #\space #\( ) #t) (else #f)))
139:   
140:   
141:   
142:   
143:   
144:   
145:   (define (find-op-idx s0)
146:     ;(print s0)
147:     (let loop((ls (keep-matching-items L_OP (lambda(x) (<= (string-length x) (string-length s0))))))
148:       (if (null? ls) (cc "can not find operator")
149:         (let* ((sop (car ls))
150:                (len (string-length sop))
151:                (s1 (string-head s0 len))
152:                (op (hash-table/get H_OP sop #f)))
153:           (if (and (string=? sop s1)
154:                    (or (op-lhb? op) 
155:                        (op-constant? op)
156:                        (and (< len (string-length s0))
157:                             (or (string-W? sop) 
158:                                 (= (operator-priority op) P_POW)
159:                                 (char-sep? (string-ref s0 len))))))
160:               len
161:             (loop (cdr ls)))))))
162:   
163:   
164:   
165:   (define (get-op s ls)
166:     (hash-table/get H_OP
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:   ;; it makes a list of numbers and operators from the given string and returns it.
174:   (define (read-input s0)
175:     (letrec ((iter (lambda (s0 ls0)
176:                      (let ((s (string-trim s0)))
177:                        ;(print s ls0)
178:                        (cond
179:                         ((= 0 (string-length s)) ; return the resulting list if the input string is finished
180:                          (reverse! ls0))
181:                         ((char=? (string-ref s 0) #\()
182:                          (let ((pos (search-close s)))
183:                            (iter (string-tail s (1+ pos)) (cons (iter (substring s 1 pos) '()) ls0))))
184:                         (else
185:                          (let ((mobj (re-string-match RNUM s)))
186:                            (if mobj
187:                                (iter (string-tail s (re-match-end-index 0 mobj))
188:                                      (cons (string->number (re-match-extract s mobj 0)) ls0))
189:                              (let ((pos (find-op-idx s)))
190:                                (let ((op (get-op (string-head s pos) ls0)))
191:                                  (iter (string-tail s pos) (cons op ls0))))))))))))
192:             (iter s0 '() )))
193:   
194:   
195:   
196:   (define (single? ls)
197:     (and
198:      (list? ls)
199:      (not (null? ls))
200:      (null? (cdr ls))))
201:   
202:   
203:   
204:   ;; it returns the position of the next operator to apply.
205:   (define (find-op ls0 priority)
206:     (let loop((ls (if (memv priority priority-reverse) (reverse ls0) ls0)) (j 0))
207:       (cond
208:        ((null? ls) #f)
209:        ((and (op-pair? (car ls)) (= (second (car ls)) priority)) 
210:         (if (memv priority priority-reverse)
211:             (- (length ls0) j 1)
212:             j))
213:        (else   (loop (cdr ls) (1+ j))))))
214:   
215:   
216:   
217:   (define (op-unary? op)
218:     (let ((p (operator-priority op)))
219:       (or (= p P_FUN) (= p P_UPM))))
220:   
221:   
222:   
223:   (define (op-lhb? op)
224:     (= (operator-priority op) P_LHB))
225:   
226:   
227:   
228:   (define (op-constant? op)
229:     (= (operator-priority op) P_CST))
230:   
231:   
232:   
233:   (define (op-binary? op)
234:     (let ((p (operator-priority op)))
235:       (or (= p P_BPM) (= p P_MD) (= p P_POW))))
236:   
237:   
238:   
239:   (define (op-reverse? op)
240:     (let ((p (operator-priority op)))
241:       (or (= p P_FUN) (= p P_POW) (= p P_UPM))))
242:   
243:   
244:   
245:   (define (op>? op1 op2)
246:     (or
247:      (not (operator? op2))
248:      ((if (op-reverse? op1) >= > ) (operator-priority op1) (operator-priority op2))))
249:   
250:   
251:   
252:   (define (find-op-pos ls0)
253:     (let loop((i 0) (pos -1) (ls ls0) (op0 #f))
254:       (if (null? ls)
255:           pos
256:         (let* ((op (car ls))
257:                (update (and (operator? op) (op>? op op0))))
258:           (loop (1+ i) (if update i pos) (cdr ls) (if update op op0))))))
259:   
260:   
261:   
262:   ;; it returns a number by calculating a list of numbers and operators
263:   (define (calc-list ls)
264:     ;(print ls)
265:     (cond
266:      ((number? ls) ls)
267:      ((single? ls) (calc-list (car ls)))
268:      ((list? ls)
269:       (let* ((pos (find-op-pos ls)) (op (list-ref ls pos)))
270:         ;(print pos (operator-name op))
271:         (calc-list
272:          (append (list-head ls (- pos (if (or (op-lhb? op) (op-binary? op)) 1 0)))
273:                  (cons
274:                   (let ((fun (operator-fun op)))
275:                     (cond
276:                      ((op-constant? op) fun)
277:                      ((op-lhb? op)   (fun (calc-list (list-ref ls (- pos 1)))))
278:                      ((op-unary? op) (fun (calc-list (list-ref ls (1+ pos)))))
279:                      ((op-binary? op) (fun (calc-list (list-ref ls (- pos 1))) (calc-list (list-ref ls (1+ pos)))))
280:                      (else (cc "funny!"))))
281:                   (list-tail ls (+ pos (if (or (op-unary? op) (op-binary? op)) 2 1))))))))
282:      (else (cc "Invarid formula!"))))
283:   
284:   
285:   
286:   ;; a read-eval-print loop for arithmetic calculation
287:   (define (calc)
288:     (let loop()
289:       (display "> ")
290:       (let ((str (read-line)))
291:         (if (string-null? str)
292:             'bye
293:           (begin
294:            (display 
295:             (call-with-current-continuation
296:              (lambda (k)
297:                (set! cc k)           ; global escape for exception
298:                (calc-list (read-input str)))))
299:            (newline)
300:            (loop))))))

注

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

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

5. 使い方

=>(cd "z:/doc/monthly/07-07/calc_scm")
;Value 15: #[pathname 15 "z:\\doc\\monthly\\07-07\\calc_scm\\"]

=>(load "calc")
;Loading "calc.com" -- done
;Value: calc

=>(calc)
>(1+2)*(15-3)
36.
>

6. 終わりに

電卓プログラムは、

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

HOME

A-1. N Queen

もうひとつの Scheme 入門

A-3. 継続についてもう少し

download

書き込む