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 (inv-x x) (round (- (/ (* 7.0 x) width) 1)))
(define (inv-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)))

(big-bang keyboard
          (on-draw (lambda (b) b))
          (on-mouse
           (lambda (_ x y what)
             (if (string=? what "button-down")
                 (let ((x (inv-x x)) (y (inv-y y)))
                   (let ((i (+ x (* 6 y))))
                     (if (< -1 i (length buttons))
                         (let ((b (list-ref buttons i)) (x (conv-x x)) (y (conv-y y)))
                           (place-image
                            (text (button-label b) (/ (* 4 (button-size b)) 3)
                                  "white")
                            x y
                            (place-image (circle 100 "solid" (button-color b)) x y
                                         keyboard)))
                         keyboard)))
                 keyboard))))