;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: DEMO-CALCULATOR; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; This file contains the simple calculator
;;; This calculator can manipulate both real numbers (e.g. 12.34) and integers,
;;; and provides +, -, *, / functions and =, clear operations.
;;; It accepts mouse-operations on buttons or numbers displayed, and keyboard inputs.
;;;
;;; ** Call (Do-Go) to start and (Do-Stop) to stop **
;;;
;;; Designed and implemented by Osamu Hashimoto
;;; CHANGES:
;;; 13-May-92 Martin Sjolin Comment out #\super-return for cmucl.
;;; 26-Mar-91 Greg Sylvain  Added patches for kcl.

(in-package "DEMO-CALCULATOR" :use '("LISP" "KR"))

(load (merge-pathnames "text-buttons-loader"
		       #+cmu "gadgets:"
		       #+(not cmu) user::Garnet-Gadgets-PathName))

(export '(Do-Go Do-Stop))

(defparameter *prev* NIL)     ; stores numbers displayed on LCD in string form
(defparameter *operand* NIL)  ; stores numbers to be calculated as a first operand
                              ; in string form
(defparameter *fun* NIL)      ; stores a function (+, -, *, /) 
(defparameter *dot-p* NIL)      ; indicates after "." is input
(defparameter *fun-p* NIL)      ; indicates after "function" is input
(defparameter *sum-p* NIL)      ; indicates after "=" is operated


(defun Do-Go (&key dont-enter-main-event-loop)
  (setq *prev* NIL *operand* NIL *fun* NIL *fun-p* NIL *dot-p* NIL *sum-p* NIL)

  (create-instance 'win inter:interactor-window
   (:left 700)(:top 200)(:width 150)(:height 240)
   (:title "Calculator")
   (:aggregate (create-instance 'agg opal:aggregate)))

  (create-instance 'frame opal:rectangle
    (:left 10)(:top 10)(:width 120)(:height 220))


;===== mouse-oparations to calculator's BUTTONS: =====

; button-interactor for mouse-operations on calculator buttons
  (create-instance 'bt garnet-gadgets:text-button-panel
    (:constant T)
    (:left (o-formula (+ (gv frame :left) 10)))
    (:top (o-formula (+ (gv frame :top) 50)))
    (:final-feedback-p NIL)
    (:gray-width 3)(:shadow-offset 3)
    (:v-spacing 7)(:h-spacing 7)
    (:text-offset 2)
    (:direction :horizontal)(:rank-margin 4)
    (:items '(("7" digit*)("8" digit*)("9" digit*)("+" op*)
              ("4" digit*)("5" digit*)("6" digit*)("-" op*)
              ("1" digit*)("2" digit*)("3" digit*)("*" op*)
              ("." dot*)  ("0" digit*)("=" sum*)  ("/" op*)
              ("C" clr*))))


;===== mouse-operations on NUMBERS displayed on the calculator's LCD: =====

; set *prev* when numbers displayed are operated by mouse
  (defun prevset* (inter obj event string x y)
    (declare (ignore inter obj event x y))
    (setq *prev* string)
    (string-to-lcd *prev*))

; text-interactor for mouse-operations on numbers displayed on LCD
  (create-instance 'lcd opal:aggregadget
    (:left (o-formula (+ (gv frame :left) 10)))
    (:top (o-formula (+ (gv frame :left) 10)))
    (:width 100)(:height 30)
    (:parts `(
        (:frame ,opal:rectangle
            (:left ,(o-formula (gvl :parent :left)))
            (:top  ,(o-formula (gvl :parent :top)))
            (:width ,(o-formula (gvl :parent :width)))
            (:height ,(o-formula (gvl :parent :height))))
        (:text ,opal:cursor-text
            (:top ,(o-formula (+ (gvl :parent :top) 5)))
            (:left ,(o-formula (+ (gvl :parent :left)
                                  (- (gvl :parent :width) (gvl :width))
                                   -5)))
            (:font ,(create-instance NIL opal:font (:size :large)))
            (:string "        "))))
    (:interactors `(
        (:prevdigit ,inter:text-interactor
            (:start-where ,(o-formula (list :in (gvl :operates-on :text))))
            (:start-event :any-mousedown)
#-kcl       (:stop-event (:any-mousedown #\return #-cmu #\super-return))
            (:window ,win)
            (:final-function ,#'prevset*)))))


; call applications when keyboard input is accepted
  (defun dispatch* (inter obj event string x y)
   (declare (ignore obj string x y))
   (let ((key (inter:event-char event)))
     (cond
       ((digit-char-p key) (digit* inter (prin1-to-string (digit-char-p key))))
       ((eq #\. key) (dot* inter ""))
       ((eq #\c key) (clr* inter ""))
       ((eq #\return key) (sum* inter ""))
       ((eq #\+ key) (op* inter "+"))
       ((eq #\- key) (op* inter "-"))
       ((eq #\* key) (op* inter "*"))
       ((eq #\/ key) (op* inter "/")))))

; text-interator for keyboard inputs
  (create-instance NIL inter:text-interactor
    (:start-event :any-keyboard)
    (:start-where (list :in frame))
    (:continuous NIL)
    (:window win)
    (:final-function #'dispatch*))

  (opal:add-components agg frame bt lcd)
  (opal:update win)

  (format t "~%Demo-Calculator:
   Press on calculator's buttons with the left mouse button,
   Type keyboard, or
   Directly input numbers on the calculator's LCD.

   For keyboard, type C key for clear and ENTER key for =.
   For direct number inputs,
   press on the calculator's LCD with any mouse buttons to start,
   and type ENTER key or press any mouse buttons to stop.
   ~%")

  (unless dont-enter-main-event-loop #-cmu (inter:main-event-loop))

)

(defun Do-Stop ()
  (opal:destroy win)
)

;===== applications: =====

(defun string-to-lcd (string)
    (s-value (g-value lcd :text) :string 
        (subseq string 0 (min (length string) 8))))

(defun digit* (g-obj num)
    (setq *fun-p* NIL)
    (if *sum-p* (clr* g-obj num))
    (if (null *prev*)
        (if (string= num "0") (return-from digit*) 
            (progn
                (setq *prev* num)
                (string-to-lcd *prev*)))
        (progn
            (setq *prev* (concatenate 'string *prev* num))
            (string-to-lcd *prev*))))

(defun dot* (g-obj dot)
    (if *sum-p* (clr* g-obj dot))
    (if (null *dot-p*)
        (if (null *prev*)
            (progn
                (setq *prev* "0.")
                (setq *fun-p* NIL)
                (string-to-lcd *prev*)
                (setq *dot-p* T))
            (progn
                (setq *prev* (concatenate 'string *prev* "."))
                (string-to-lcd *prev*)
                (setq *dot-p* T)))
        (return-from dot*)))

(defun clr* (g-obj num)
    (declare (ignore g-obj num))
    (setq *prev* NIL)
    (setq *dot-p* NIL)
    (setq *fun-p* NIL)
    (setq *operand* NIL)
    (string-to-lcd "")
    (setq *sum-p* NIL))

(defun set-op (op)
    (cond
        ((string= op "+") (setq *fun* '+))
        ((string= op "-") (setq *fun* '-))
        ((string= op "*") (setq *fun* '*))
        ((string= op "/") (setq *fun* '/))))

(defun op* (g-obj op)
  (declare (ignore g-obj))
  (if *fun-p*
    (set-op op)
    (if (or (null *operand*)  *sum-p*)
      (progn
        (setq *operand* *prev*)
        (setq *prev* NIL)
        (setq *dot-p* NIL)
        (setq *fun-p* T)
        (set-op op)
        (if *sum-p* (setq *sum-p* NIL)))
      (progn
        (let ((result (funcall *fun*
            (read-from-string *operand*)(read-from-string *prev*))))
        (if (not (integerp result)) (setq result (float result)))
        (setq *operand* (prin1-to-string result))
        (string-to-lcd *operand*)
        (setq *prev* NIL)
        (setq *dot-p* NIL)
        (setq *fun-p* T)
        (set-op op))))))

(defun sum* (g-obj fun)  
  (declare (ignore g-obj fun))
  (if *fun-p*
    (return-from sum*)
    (if (null *operand*)
        (return-from sum*)
        (progn
          (let ((result (funcall *fun*
              (read-from-string *operand*)(read-from-string *prev*))))
          (if (not (integerp result)) (setq result (float result)))
          (setq *prev* (prin1-to-string result))
          (string-to-lcd *prev*)
          (setq *operand* NIL)
          (setq *dot-p* NIL)
          (setq *fun* NIL)
          (setq *sum-p* T))))))

