calculator.scm

; 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) (num-f input)))
                     (set! input
                       (make-num plus (rcons (num-i input) n) (num-f input))))
                 (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 (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)))
(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 "÷" ignore)
   (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))))