calculator.scm

; Calculator for Simple Scheme

(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 "gray")
   (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 input (make-num " " '(0) '())) (define window input)
(define result #f) (define memory input)

(define (overlay-window scn)
  (let* ((lis (map number->string (append (num-i window) (num-f window))))
         (wdx (* width (/ 3/4 (+ max-ndigits 1/2)))) (iwdx (round wdx))
         (wconv-x (lambda (x)
                    (round (+ (* width 1/8)
                              (* wdx (+ x (- max-ndigits (length lis)) 1))))))
	 (y (/ width 8)))
    (foldl (lambda (x scn) (place-image (text (car x) iwdx "black") (cadr x) y scn))
           (place-image (text "." iwdx "black")
                        (wconv-x (- (length (num-i window)) 0.5)) y
                        (place-image (text (num-sign window) iwdx "black")
                                     (wconv-x -0.8) y scn))
           (build-list (length lis)
                       (lambda (i) (list (list-ref lis i) (wconv-x i)))))))

(define calculator-image (overlay-window keyboard))

(define (rcons xs x) (append xs (list x)))
(define which-part 'int)
(define (input-number n)
  (lambda ()
    (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 " " (list n) (num-f input)))
                   (set! input (make-num " " (rcons (num-i input) n) (num-f input))))
               (set! input (make-num " " (num-i input) (rcons (num-f input) n))))
           (set! window input)))))
(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 "." (lambda () (set! which-part 'frac)))
   (list "+" ignore) (list "-" ignore) (list "×" ignore) (list "÷" ignore)
   (list "√" ignore) (list "=" ignore) (list "%" ignore) (list "AC" ignore)
   (list "C" ignore) (list "MR" ignore) (list "M+" ignore) (list "M-" ignore)))
(define button-funcs
  (map (lambda (b) (cadar (filter (lambda (p) (string=? (car p) 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))))