Last active
March 18, 2020 14:49
-
-
Save brv00/d8c99866d3509e6ec8008280b72192e0 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
; Calculator for Simple Scheme | |
(define (assoc k al) (car (filter (lambda (x) (string=? k (car x))) al))) | |
(define button-labels | |
'("%" "7" "8" "9" "÷" "MR" | |
"√" "4" "5" "6" "×" "M-" | |
"C" "1" "2" "3" "-" "M+" | |
"AC" "0" "." "=" "+")) | |
(define width (image-width (empty-scene))) | |
(define (conv-x x) (/ (* width (+ 1 x)) 7)) | |
(define (conv-y y) (/ (* width (+ 2 y)) 7)) | |
(define (iconv-x x) (round (- (/ (* 7.0 x) width) 1))) | |
(define (iconv-y y) (round (- (/ (* 7.0 y) width) 2))) | |
(define-struct button-category (labels size color)) | |
(define button-categories | |
(list | |
(make-button-category '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" ".") 80 "#888") | |
(make-button-category '("+" "-" "×" "÷" "=" "%" "√") 70 "black") | |
(make-button-category '("MR" "M+" "M-") 60 "blue") | |
(make-button-category '("AC" "C") 60 "red"))) | |
(define-struct button (label size color)) | |
(define buttons | |
(letrec ((find (lambda (lis b) | |
(let ((bc (car lis))) | |
(if (ormap (lambda (l) (string=? b l)) | |
(button-category-labels bc)) | |
(make-button b (button-category-size bc) | |
(button-category-color bc)) | |
(find (cdr lis) b)))))) | |
(map (lambda (l) (find button-categories l)) button-labels))) | |
(define (place-buttons x y buttons scn) | |
(if (null? buttons) | |
scn | |
(let* ((b (car buttons)) | |
(scn (place-image (text (button-label b) (button-size b) | |
(button-color b)) | |
(conv-x x) (conv-y y) scn))) | |
(if (>= x 5) | |
(place-buttons 0 (++ y) (cdr buttons) scn) | |
(place-buttons (++ x) y (cdr buttons) scn))))) | |
(define max-ndigits 8) | |
(define keyboard | |
(place-image (round-rectangle (round (* 27/34 width)) 150 5 "outline" "gray") | |
(/ width 2) (/ width 7) (place-buttons 0 0 buttons (empty-scene)))) | |
(define-struct num (sign i f)) (define plus "") (define minus "-") | |
(define zero (make-num plus '(0) '())) (define input zero) (define window input) | |
(define result zero) (define memory input) | |
(define op-no 0) (define op-labels (list "" "+" "-" "×" "÷")) | |
(define overlay-window | |
(let* ((wdx (* width (/ 3/4 (+ max-ndigits 1/2)))) (iwdx (round wdx)) | |
(wy (* width 9/64)) (sy (* width 5/64)) | |
(sconv-x (lambda (x) (round (* width (- 9/10 (* 1/20 x))))))) | |
(lambda (scn) | |
(let* ((lis (map number->string (append (num-i window) (num-f window)))) | |
(wconv-x (lambda (x) | |
(round (+ (* width 1/8) | |
(* wdx (+ x (- max-ndigits (length lis)) 1)))))) | |
(scn (place-image (text (list-ref op-labels op-no) 60 "#888") | |
(sconv-x op-no) sy scn))) | |
(foldl (lambda (x scn) | |
(place-image (text (car x) iwdx "black") (cadr x) wy scn)) | |
(place-image (text "." iwdx "black") | |
(wconv-x (- (length (num-i window)) 0.5)) wy | |
(place-image (text (num-sign window) iwdx "black") | |
(wconv-x -0.8) wy scn)) | |
(build-list (length lis) | |
(lambda (i) (list (list-ref lis i) (wconv-x i))))))))) | |
(define calculator-image (overlay-window keyboard)) | |
; 入力関係 | |
(define waiting 'waiting) (define inputting 'inputting) (define mode waiting) | |
; 数字ボタンの入力 | |
(define (rcons xs x) (append xs (list x))) | |
(define which-part 'int) | |
(define (input-number n) | |
(lambda () | |
(begin | |
(and (symbol=? mode waiting) | |
(begin (set! mode inputting) (set! which-part 'int) (set! input zero))) | |
(and (< (+ (length (num-i input)) (length (num-f input))) max-ndigits) | |
(begin | |
(if (symbol=? which-part 'int) | |
(if (and (null? (cdr (num-i input))) (= 0 (car (num-i input)))) | |
(set! input (make-num plus (list n) '())) | |
(set! input (make-num plus (rcons (num-i input) n) '()))) | |
(set! input (make-num plus (num-i input) (rcons (num-f input) n)))) | |
(set! window input)))))) | |
(define (input-point) | |
(begin (and (symbol=? mode waiting) | |
(begin (set! mode inputting) (set! input zero) (set! window input))) | |
(set! which-part 'frac))) | |
; 加減乗除の計算 | |
(define (i/% x y) | |
(let ((q (/ x y)) (r (% x y))) (if (< r 0) (list (-- q) (+ r y)) (list q r)))) | |
(define (map2 f l1 l2) | |
(build-list (length l1) (lambda (i) (f (list-ref l1 i) (list-ref l2 i))))) | |
(define (carry x ds) (append (i/% (+ x (car ds)) 10) (cdr ds))) | |
(define (norm xs) (foldr carry '(0) xs)) | |
(define (lop op xs ys) (norm (map2 op xs ys))) | |
(define (get-padding xs n) (build-list (max 0 (- n (length xs))) (lambda (_) 0))) | |
(define (trim xs n) (take (append xs (get-padding xs n)) n)) | |
(define (align x y) | |
(let* ((ix (num-i x)) (iy (num-i y)) (li (max (length ix) (length iy))) | |
(ix (append (get-padding ix li) ix)) (iy (append (get-padding iy li) iy))) | |
(values li (trim (append ix (num-f x)) max-ndigits) | |
(trim (append iy (num-f y)) max-ndigits)))) | |
(define (drop0s xs) (if (and (cons? xs) (= (car xs) 0)) (drop0s (cdr xs)) xs)) | |
(define (rdrop0s xs) (reverse (drop0s (reverse xs)))) | |
(define (add x y) | |
(if (string=? (num-sign x) (num-sign y)) | |
(let*-values (((li xs ys) (align x y)) ((zs) (lop + xs ys)) | |
((zs li) | |
(if (= (car zs) 0) (values (cdr zs) li) (values zs (++ li))))) | |
(make-num (num-sign x) (take zs li) | |
(rdrop0s (drop (trim zs max-ndigits) (min li max-ndigits))))) | |
(sub x (make-num (num-sign x) (num-i y) (num-f y))))) | |
(define (l<? xs ys) | |
(and (cons? xs) | |
(or (< (car xs) (car ys)) | |
(and (= (car xs) (car ys)) (l<? (cdr xs) (cdr ys)))))) | |
(define (neg sign) (if (string=? sign plus) minus plus)) | |
(define (sub x y) | |
(if (string=? (num-sign x) (num-sign y)) | |
(let*-values (((li xs ys) (align x y)) | |
((sign zs) (if (l<? xs ys) | |
(values (neg (num-sign x)) (cdr (lop - ys xs))) | |
(values (num-sign x) (cdr (lop - xs ys))))) | |
((i) (drop0s (take zs li))) ((f) (rdrop0s (drop zs li)))) | |
(if (null? i) | |
(if (null? f) (make-num plus '(0) '()) (make-num sign '(0) f)) | |
(make-num sign i f))) | |
(add x (make-num (num-sign x) (num-i y) (num-f y))))) | |
(define (mul-signs-of x y) (if (string=? (num-sign x) (num-sign y)) plus 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)) | |
(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)))))))) | |
(define (ldiv xs y carry-digit) | |
(foldl (lambda (x ds) (append (reverse (i/% (+ x (* 10 (car ds))) y)) (cdr ds))) | |
(list carry-digit) xs)) | |
(define (div x y) | |
(let ((sign (mul-signs-of x y)) (lfy (length (num-f y))) (y (num->int y))) | |
(let* ((ix (append (num-i x) (trim (num-f x) lfy))) (rq (ldiv ix y 0)) | |
(i (drop0s (reverse (cdr rq)))) (i (if (null? i) '(0) i))) | |
(if (> (length i) max-ndigits) | |
(make-num sign i '()) | |
(let ((fx (drop (trim (num-f x) (- (+ max-ndigits lfy) (length i))) lfy))) | |
(make-num sign i (reverse (drop0s (cdr (ldiv fx y (car rq))))))))))) | |
; 演算ボタンの入力 | |
(define (get2nd x y) (make-num (num-sign y) (num-i y) (rdrop0s (num-f y)))) | |
(define op-alist | |
(list (list "" get2nd) (list "+" add) (list "-" sub) (list "×" mul) (list "÷" div))) | |
(define ops (map (lambda (l) (cadr (assoc l op-alist))) op-labels)) | |
(define (make-op i) | |
(lambda () | |
(begin (and (symbol=? mode inputting) | |
(begin (set! result ((list-ref ops op-no) result input)) | |
(set! window result))) | |
(set! op-no i) (set! mode waiting)))) | |
(define (input=) | |
(begin (and (symbol=? mode inputting) | |
(begin (set! result ((list-ref ops op-no) result input)) | |
(set! window result))) | |
(set! op-no 0) (set! mode waiting))) | |
; クリアボタンの入力 | |
(define (inputAC) | |
(begin (set! op-no 0) (set! result zero) (set! window result) | |
(set! mode waiting))) | |
(define (inputC) | |
(if (symbol=? mode inputting) | |
(begin (set! which-part 'int) (set! input zero) (set! window input)) | |
(inputAC))) | |
(define (ignore) #f) | |
(define func-alist | |
(list | |
(list "0" (input-number 0)) (list "1" (input-number 1)) (list "2" (input-number 2)) | |
(list "3" (input-number 3)) (list "4" (input-number 4)) (list "5" (input-number 5)) | |
(list "6" (input-number 6)) (list "7" (input-number 7)) (list "8" (input-number 8)) | |
(list "9" (input-number 9)) (list "." input-point) (list "+" (make-op 1)) | |
(list "-" (make-op 2)) (list "×" (make-op 3)) (list "÷" (make-op 4)) | |
(list "√" ignore) (list "=" input=) (list "%" ignore) (list "AC" inputAC) | |
(list "C" inputC) (list "MR" ignore) (list "M+" ignore) (list "M-" ignore))) | |
(define button-funcs (map (lambda (b) (cadr (assoc b func-alist))) button-labels)) | |
(big-bang | |
calculator-image | |
(on-draw (lambda (b) b)) | |
(on-mouse | |
(lambda (_ x y what) | |
(if (string=? what "button-down") | |
(let ((x (iconv-x x)) (y (iconv-y y))) | |
(let ((i (+ x (* 6 y)))) | |
(if (and (<= 0 x) (< x 6) (<= 0 i) (< i 23)) | |
(let ((b (list-ref buttons i)) (x (conv-x x)) (y (conv-y y))) | |
(begin | |
((list-ref button-funcs i)) | |
(set! calculator-image (overlay-window keyboard)) | |
(place-image | |
(text (button-label b) (/ (* 4 (button-size b)) 3) "white") x y | |
(place-image (circle 100 "solid" (button-color b)) x y | |
calculator-image)))) | |
calculator-image))) | |
calculator-image)))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment