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 keyboard (place-buttons 0 0 buttons (empty-scene)))

(define i-part '(0)) (define f-part '()) (define which-part 'int)

(define max-ndigits 8)

(define wdx (* width (/ 2/3 (-- max-ndigits))))
(define (wconv-x x) (round (- (* width 5/6) (* wdx x))))

(define (overlay-window scn)
  (letrec ((place-num
            (lambda (d lis scn part)
              (if (null? lis)
                  (if (symbol=? part 'int)
                      scn
                      (place-num d i-part
                                 (place-image (text "." (round wdx) "black")
                                              (wconv-x (- d 0.5)) (/ width 7) scn)
                                 'int))
                  (place-num (++ d) (cdr lis)
                             (place-image (text (number->string (car lis))
                                                (round wdx) "black")
                                          (wconv-x d) (/ width 7) scn)
                             part)))))
    (place-num 0 f-part scn 'frac)))

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

(define (input-number n)
  (lambda ()
    (and (< (+ (length i-part) (length f-part)) max-ndigits)
         (if (symbol=? which-part 'int)
             (if (and (null? (cdr i-part)) (= 0 (car i-part)))
                 (set! i-part (list n))
                 (set! i-part (cons n i-part)))
             (set! f-part (cons n f-part))))))
(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))))