A slope module for performing calculation with infix math (instead of prefix)
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

113 lines
4.3 KiB

;;; infix-math - calculate infix math strings in slope
;;; Author: sloum
;;; Version: 0.1.0
(define is-keyword? (lambda (val) (or (is-op? val) (member? ["(" ")"] val))))
(define is-op? (lambda (val) (member? ["-" "+" "*" "/" "<" ">" "="] val)))
(define is-digit? (lambda (val) (and (>= (string->rune val) 48) (<= (string->rune val) 57))))
(define op-associativity (lambda (op) (if (member? ["-" "+" "*" "/"] op) -1 1)))
(define op-precedence
(lambda (op)
((member? ["=" "<" ">"] op) 1)
((member? ["+" "-"] op) 2)
((member? ["*" "/"] op) 3)
((equal? "^" op) 4)
(else 0))))
(define op-actions (lambda (stmt stack)
(define tok-prec (op-precedence (car stmt)))
(define tok-assoc (op-associativity (car stmt)))
(define stack-op (if (not (null? stack)) (car stack) []))
(define stack-prec (if (not (null? stack-op)) (op-precedence stack-op) 0))
(and (negative? tok-assoc) (<= tok-prec stack-prec))
(and (positive? tok-assoc) (< tok-prec stack-prec)))
(cons stack-op (shunting-yard stmt (cdr stack)))
(shunting-yard (cdr stmt) (cons (car stmt) stack)))))
(define stack-ops (lambda (stack)
((and (not (null? stack)) (equal? (car stack) "("))
(! "Unbalanced parens"))
((null? stack) stack)
(else (cons (car stack) (shunting-yard [] (cdr stack)))))))
(define shunting-yard (lambda (stmt stack)
((null? stmt)
(stack-ops stack))
((string->number (car stmt))
(cons (car stmt) (shunting-yard (cdr stmt) stack)))
((is-op? (car stmt))
(op-actions stmt stack))
((equal? (car stmt) "(")
(shunting-yard (cdr stmt) (cons (car stmt) stack)))
((equal? (car stmt) ")")
(if (and (pair? stack) (equal? "(" (car stack)))
(shunting-yard (cdr stmt) (cdr stack))
(cons (car stack) (shunting-yard stmt (cdr stack))))))))
(define prefix-calc (lambda (arr)
(define s [])
(if (null? arr)
(lambda (v)
(if (is-op? v)
((equal? v "+") (set! s (cons (+ (car (cdr s)) (car s)) (cdr (cdr s)))))
((equal? v "-") (set! s (cons (- (car (cdr s)) (car s)) (cdr (cdr s)))))
((equal? v "*") (set! s (cons (* (car (cdr s)) (car s)) (cdr (cdr s)))))
((equal? v "/") (set! s (cons (/ (car (cdr s)) (car s)) (cdr (cdr s))))))
(set! s (cons (string->number v) s))))
(shunting-yard arr []))
(if (not (equal? (length s) 1)) (! "Invalid prefix expression") (car s))))))
(define parse-string (lambda (input)
(set! input (append "" input))
(define prev "")
(lambda (val acc)
((member? [" " "\t" "\n" "\r"] val) acc)
((and (is-digit? val) (not (null? acc)) (equal? prev "-"))
(cons (append (car acc) val) (cdr acc)))
((is-keyword? val) (cons val acc))
((and (not (null? acc)) (is-keyword? (car acc))) (cons val acc))
(else (if (null? acc) (cons val acc) (cons (append (car acc) val) (cdr acc)))))
(set! prev val)))
(string->list input)))))
(define replace-vars (lambda (ex en)
(define panic? (exception-mode-panic?))
(if panic? (exception-mode-pass))
(if (or (null? en) (not (assoc? en)))
(lambda (e)
(if (not (exception? (assoc en e)))
(append "" (assoc en e))
(if panic? (exception-mode-panic)))))
(define calc (lambda (exp ...)
(if (list? exp)
(set! exp (map (lambda (v) (append "" v)) exp))
(set! exp (parse-string exp)))
(if (and (not (null? ...)) (assoc? (car ...)))
(set! exp (replace-vars exp (car ...))))
(prefix-calc exp)))
(define _USAGE [
["calc" "(infix-math::calc [problem: string|list] [[vars: assoc]]) => number\n\nThe available operations for a problem are:\n\n\t+, -, *, /, (, and )\n\nPositive, negative, floating point, and integer numbers are all supported. If using subtraction there must be a space between the operator and the operand so-as to prevent confusion between a negative number and a subtraction operation. Variables should be given as an associative list of key value pairs. The key should be a string as it would appear in the problem and the value will replace it in the actual calculation"]])