libre-rpn/lisp/rpn.lisp

(load "./list.lisp")
(load "./math.lisp")

(defvar *stack* '())

(defun clear-operand! ()
  (let ((elem ((@ document get-element-by-id) "operand")))
    (setf (@ elem inner-H-T-M-L)  "")))

(defun add-to-stack! ()
  (let* ((elem ((@ document get-element-by-id) "operand"))
         (value (@ elem inner-H-T-M-L)))
    (if (string= value "")
        (setf *stack* (append (list (car *stack*)) *stack*))
        (setf *stack* (append (list value) *stack*)))
    (clear-operand!)))

(defun remove-from-stack (n)
  (let ((new-stack *stack*))
    (dotimes (i n)
      (setf new-stack (cdr new-stack) ))
    new-stack))

(defun render-stack! ()
  (let* ((e ((@ document get-element-by-id) "stack"))
         (left-softkey ((@ document get-element-by-id) "left"))
         (i (length *stack*))
         (html (if (zero? i)
                   ""
                   (reduce
                    (lambda (a c)
                      (setf i (1- i))
                      (let* ((body (concatenate 'string i ":  " c))
                             (n (ps-html
                                 ((:div :id c
                                        :class "stack-item")
                                  body))))
                        (if (eq 'start a)
                            n
                            (concatenate 'string a n))))
                    (reverse *stack*)
                    'start))))
    (setf (@ left-softkey inner-H-T-M-L) "Drop")
    (setf (@ e inner-H-T-M-L) html)))

(defun do-operation! (operation number-required)
  (let ((elem ((@ document get-element-by-id) "operand")))
    (if (string= (@ elem inner-H-T-M-L) "")
        (if (or (null? *stack*)
                (< (length *stack*) number-required))
            (error (concatenate 'string
                                "Need "
                                number-required
                                " items in the stack to preform "
                                (symbol-to-js-string operation)))
            (let* ((operands (subseq *stack* 0 number-required))
                   (numerical-answer (if (= 1 (length operands))
                                         (operation (-Number (car operands)))
                                         (reduce
                                          (lambda (a c)
                                            (let ((na (-Number a))
                                                  (nc (-Number c)))
                                              (cond
                                                ((and a c)
                                                 (operation na nc))
                                                (a
                                                 (operation na))
                                                (c
                                                 (operation nc))
                                                (otherwise
                                                 a))))
                                          operands)))
                   (answer (-String numerical-answer))
                   (stack-without (remove-from-stack number-required)))
              (setf *stack* (append (list answer) stack-without))))
        (if (null? *stack*)
            (error (concatenate 'string
                                "Need "
                                (1- number-required)
                                " items in the stack to preform "
                                (symbol-to-js-string operation)))
            (let* ((elem ((@ document get-element-by-id) "operand"))
                   (stack (append (list (@ elem inner-H-T-M-L)) *stack*))
                   (operands (reverse (subseq stack 0 number-required))) ;for operations that don't have the associative property
                   (numerical-answer (if (= 1 (length operands))
                                         (operation (-Number (car operands)))
                                         (reduce
                                          (lambda (a c)
                                            (let ((na (-Number a))
                                                  (nc (-Number c)))
                                              (cond
                                                ((and a c)
                                                 (operation na nc))
                                                (a
                                                 (operation na))
                                                (c
                                                 (operation nc))
                                                (otherwise
                                                 a))))
                                          operands)))
                   (answer (-String numerical-answer))
                   (stack-without (remove-from-stack (1- number-required))))
              (setf *stack* (append (list answer) stack-without)))))
    (render-stack!)
    (clear-operand!)))

(defun clear-all! ()
  (setf *stack* (list))
  (render-stack!))

(chain
 document
 (add-event-listener
  "keydown"
  (lambda (e)
    ;; ((@ e prevent-default))
    (let ((key (@ e key)))
      (case key
        ("Enter"
         (progn
           (add-to-stack!)
           (render-stack!)))
        ("ArrowDown"
         (do-operation! (lambda (x y) (+ x y)) 2))
        ("ArrowUp"
         (do-operation! (lambda (x y) (- x y)) 2))
        ("ArrowRight"
         (do-operation! (lambda (x y) (* x y)) 2))
        ("ArrowLeft"
         (do-operation! (lambda (x y) (/ x y)) 2))
        ("#"
         (do-operation! (lambda (x) (* x -1)) 1))
        ("*"
         (let* ((input ((@ document get-element-by-id) "operand"))
                (value (@ input inner-H-T-M-L)))
           (setf (@ input inner-H-T-M-L) (concatenate 'string value "."))))
        ("SoftLeft"
         (let ((input ((@ document get-element-by-id) "operand")))
           (if (string= (@ input inner-H-T-M-L) "")
               (progn
                 (setf *stack* (cdr *stack*))
                 (render-stack!))
               (clear-operand!))))
        ("SoftRight"                    ;preform a swap
         (when (>= (length *stack*) 2)
           (let ((fir (car *stack*))
                 (sec (cadr *stack*)))
             (setf *stack* (append (list sec fir) (cddr *stack*)))
             (render-stack!))))
        ("Call"                         ;preform a roll
         (when (>= (length *stack*) 2)
           (let ((fir (car *stack*)))
             (setf *stack* (append (cdr *stack*) (list fir)))
             (render-stack!))))
        ("Backspace"
         (close))
        ("MicrophoneToggle"
         nil)
        (otherwise
         (let* ((input ((@ document get-element-by-id) "operand"))
                (left-softkey ((@ document get-element-by-id) "left"))
                (value (@ input inner-H-T-M-L)))
           (setf (@ left-softkey inner-H-T-M-L) "Clear")
           (if value
               (setf (@ input inner-H-T-M-L) (concatenate 'string value key))
               (setf (@ input inner-H-T-M-L) (concatenate 'string key))))))))))

(chain
 document
 (add-event-listener
  "DOMContentLoaded"
  (lambda ()
    (let ((input ((@ document get-element-by-id) "operand"))
          (left-softkey ((@ document get-element-by-id) "left"))
          (enter-key ((@ document get-element-by-id) "middle"))
          (right-softkey ((@ document get-element-by-id) "right")))
      (setf (@ input inner-H-T-M-L) "")
      (setf (@ left-softkey inner-H-T-M-L) "Drop")
      (setf (@ enter-key inner-H-T-M-L) "ENTER")
      (setf (@ right-softkey inner-H-T-M-L) "Swap")))))