#lang racket

(require "stack.rkt")
(provide do-function)
(define all-types '(#\S #\C #\R #\N #\B))

(define (string-case key . objects)
  (define (match-helper l)
    (cond ((null? l) #f)
          ((string=? (car l) key) #t)
          (else (match-helper (cdr l)))
          )
    )
  (define (match remaining)
    (cond ((null? (cdr remaining)) (car remaining))
          ((match-helper (caar remaining)) (cadar remaining))
          (else (match (cdr remaining))))
    )
  (match objects)
  )

(define (give-error msg . args)
  (define (iter msg args)
    (let ((m msg) (a args))
      (cond ((null? msg) (for-each (lambda (a) (display a) (display ", ")) args))
            ((null? args) (newline)(error (car msg)))
            (else (display (car msg))
                  (display (car args))
                  (iter (cdr msg) (cdr args))))
      )
    )
  (iter msg args)
  )

(define (get-requirements token)
  (case (car token)
    ((#\O) (string-case (cdr token)
             '(("neg") ((#\N)))
             '((#\N) (#\N))
             ))
    ((#\M) '( (#\N #\B #\C) (#\N #\B #\C)))
    ((#\V) (string-case (cdr token)
             '(("not") ((#\B)))
             '((#\B) (#\B))
             ))
    (else (string-case (cdr token)
            '(("load") ((#\R)))
            '(("save") ((#\R) (#\S #\C #\R #\N #\B)))
            '(("ref") ((#\N)))
            '(("concat") ((#\S) (#\S)))
            '(("substr") ((#\N)(#\N)(#\S)))
            '(("length" "toint" "tobool") ((#\S)))
            '(("getchar") ((#\N) (#\S)))
            '(("putchar") ((#\C) (#\N)(#\S)))
            '(("tostring") ((#\N #\B)))
            '(("drop" "dup") ((#\S #\C #\R #\N #\B)))
            '(("swap") ((#\S #\C #\R #\N #\B) (#\S #\C #\R #\N #\B)))
            '(("rot") ((#\S #\C #\R #\N #\B) (#\S #\C #\R #\N #\B) (#\S #\C #\R #\N #\B)))
            '(("write") ((#\C)))
            '()
            ))
    )
  )

(define (match token)

  (define (match-reqs reqs token)
    (cond ((null? reqs) #f)
          ((char=? (car reqs) token) #t)
          (else (match-reqs (cdr reqs) token))
          )
    )

  (define (match-each token-reqs tokens)
    (cond ((null? token-reqs) #f)
          ((match-reqs (car token-reqs) (caar tokens))
           (match-each (cdr token-reqs) (cdr tokens)))
          (else (cons token-reqs tokens)))
    )
  (define requirements (get-requirements token))
  (define inputs (map (lambda (t) (pop)) requirements))
  (let ((match-error? (match-each requirements inputs)))
    (if match-error?
        (give-error '("Runtime error: " " expects " ", got " "runtime error")
                    (cdr token) requirements inputs)
        inputs)
    )
  )

(define (get-vals tokens)
  (map (lambda (t)
         (if (pair? (cdr t))
             (cadr t)
             (cdr t)))
         tokens))

(define (do-function token)

  (let* ((inputs (match token))
         (args (get-vals inputs))
         (is (lambda (a) (string=? a (cdr token))))
         (next-arg (lambda ()
                    (let ((return (car args)))
                      (set! args (cdr args))
                      return))))
    (case (car token)
      ((#\O) (cond
               ((is "+") (push (cons #\N (+ (next-arg) (next-arg)))))
               ((is "-") (push (let ((a (next-arg)) (b (next-arg)))
                                 (cons #\N (- b a)))))
               ((is "*") (push (cons #\N (* (next-arg) (next-arg)))))
               ((is "/") (let ((a (next-arg)) (b (next-arg)))
                           (push (cons #\N (quotient b a)))
                           (push (cons #\N (remainder b a)))))
               ((is "neg") (push (cons #\N (* -1 (next-arg)))))
               ))
      ((#\M) (let ((y (next-arg)) (x (next-arg)))
               (cond ((and (char? x) (char? y))
                      (set! x (char->integer x))
                      (set! y (char->integer y)))
                     ((and (boolean? x) (boolean? y))
                      (set! x (if x 1 0))
                      (set! y (if y 1 0)))
                     ((and (number? x) (number? y)) '())
                     (else (give-error '("Runtime error: " " expects two arguments of same type, got " " and " "runtime error")
                                       (cdr token) x y)))
               (cond
                 ((is "<") (push (cons #\B (< x y))))
                 ((is ">") (push (cons #\B (> x y))))
                 ((is ">=") (push (cons #\B (>= x y))))
                 ((is "<=") (push (cons #\B (<= x y))))
                 ((is "=") (push (cons #\B (= x y))))
                 ((is "!=") (push (cons #\B (not (= x y)))))
               )))
      ((#\V) (cond
               ((is "and") (push (cons #\B (and (next-arg) (next-arg)))))
               ((is "or") (push (cons #\B (or (next-arg) (next-arg)))))
               ((is "not") (push (cons #\B (not (next-arg)))))
               ))
      ((#\F) (cond
               ((is "concat") (let ((y (next-arg)) (x (next-arg)))
                                (push (cons #\S (string-append x y)))))
               ((is "substr") (let* ((l (next-arg)) (p (next-arg)) (s (next-arg)) (len (string-length s)))
                                (cond ((> p (- len 1))
                                       (give-error '("Runtime error: start position at " " invalid for string \"" "\"" "runtime error")
                                                   p s ""))
                                      ((< len (+ p l))
                                       (push (cons #\S (substring s p))))
                                      (else (push (cons #\S (substring s p (+ p l))))))))
               ((is "length") (push (cons #\N (string-length (next-arg)))))
               ((is "getchar") (let ((i (next-arg))(s (next-arg)))
                                 (if (> (+ i 1) (string-length s))
                                     (give-error '("Runtime error: position " " exceeds length of string \"" "\"" "runtime error")
                                                 i s "")
                                     (push (cons #\C (string-ref s i))))))
               ((is "putchar") (let ((c (next-arg)) (i (next-arg)) (s (next-arg)))
                                (if (< i (string-length s))
                                    (begin (string-set! s i c)
                                    (push (cons #\S s)))
                                    (give-error '("Runtime error: position " " exceeds length of string\"" "\"" "runtime error")
                                                i s ""))))
               ((is "tostring") (let ((i (next-arg)))
                                  (cond ((boolean? i)
                                         (if i
                                             (push (cons #\S "true"))
                                             (push (cons #\S "false"))))
                                        (else (push (cons #\S (number->string i)))))))
               ((is "toint") (let ((i (next-arg)))
                               (if (string->number i)
                                   (push (cons #\N (string->number i)))
                                   (give-error '("Runtime error: string \"" "\" does not represent a number" "runtime error")
                                               i ""))))
               ((is "tobool") (let ((i (next-arg)))
                                (cond ((string=? i "true") (push (cons #\B #t)))
                                      ((string=? i "false") (push (cons #\B #f)))
                                      (else (give-error '("Runtime error: String \"" "\" does not represent a boolean value" "runtime error")
                                                        i "")))))
               ((is "drop") '())
               ((is "dup") (let ((a (car inputs)))
                             (push a)
                             (push a)))
               ((is "swap") (let ((a (car inputs)) (b (cadr inputs)))
                              (push a)
                              (push b)))
               ((is "rot") (let ((a (car inputs)) (b (cadr inputs)) (c (caddr inputs)))
                             (push a)
                             (push c)
                             (push b)))
               ((is "read") (push (cons #\C (read-char))))
               ((is "write") (display (next-arg)))
               ((is "save") (save (next-arg) (cdr inputs)))
               ((is "load") (push (load (next-arg))))
               ((is "ref") (push (cons #\R (next-arg))))
               ))

      ))
  )