![]() |
![]() |
![]() |
![]() |
![]() |
![]() |
このプログラムのミソは、演算子を 名前、手続き、 優先度 をメンバーにもつ構造体として表現していることです。 こうすることで、全ての演算を統一的に扱うことができます。
演算子 | 優先度 | 同じ優先度の計算順序 | 例 |
---|---|---|---|
定数 | 6 | 左から | pi, e |
階乗 | 5 | 左から | ! |
算術関数 | 4 | 右から | sin, log, exp |
累乗 | 3 | 右から | ^ |
単項の +/- | 2 | 右から | +, - |
乗除 | 1 | 左から | *,/,% |
加減 | 0 | 左から | +, - |
文字列 | 変換後のリスト |
---|---|
1+2 | (1.0 <+> 2.0) |
(2+3)*4 | ((2.0 <+> 3.0) <*> 4.0) |
-2*sin(pi) | (<@-> 2.0 <*> <sin> <pi>) |
(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
[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) ...................)の省略記法。詳しくはここをみてください。
> (load/cd "calc.scm") > (calc) > (1+2)*(15-3) 36 > bye
電卓プログラムは、
![]() |
![]() |
![]() |
![]() |
![]() |
![]() |