(define (pop stack)
 (let ((var (car stack))
               (ret-stack (cdr stack)))
       (values var ret-stack)))

(define (push var stack)
 (append (list var) stack))

(define (dup stack)
 (let ((head (car stack)))
       (append (list head) stack)))

(define (fact x)
 (define (fact-iter n current)
       (if (= n 1)
         current
         (fact-iter (- n 1) (* n current))))
 (fact-iter x 1))

(define (rpn-func func args stack)
 (if (= args 1)
       (let-values (((var stack) (pop stack)))
         (push (func var) stack))
       (let*-values (((var1 stack) (pop stack))
                                 ((var2 stack) (pop stack)))
         (push (func var2 var1) stack))))
;;        (push (func var1 var2) stack))))

(define (insert-into-alist key val alist)
 (let ((mem? (assq key alist)))
       (if mem?
         (update-alist key val alist)
         (append alist (list (cons key val))))))

(define (index-in-alist key alist)
 (let loop ((list (list-copy alist))
                        (index 0))
       (if (= (length list) 0)
         #f
         (let ((list-head-key (car (car list))))
               (if (eq? list-head-key key)
                 index
                 (loop (cdr list) (+ index 1)))))))

(define (update-alist key new-val alist)
 (let ((index (index-in-alist key alist)))
       (list-set! alist index (cons key new-val))
       alist))

(define (run-func sym dict stack)
 (let ((func (assq sym dict)))
       (if func
         ((cdr func) stack dict)
         (begin
               (display "ERROR: symbol not in dictionary: ")
               (display sym)
               (newline)
               stack))))

(define (swap stack)
 (let ((a (car stack))
                (b (cadr stack)))
       (append (list b) (list a) (cddr stack))))

(define init-dict
 (list (cons '$ (lambda (stack dict)
                                  (let-values (((var stack) (pop stack)))
                                        (display var)
                                        (newline)
                                        stack)))
               (cons '+ (lambda (stack dict) (rpn-func + 2 stack)))
               (cons '- (lambda (stack dict) (rpn-func - 2 stack)))
               (cons '* (lambda (stack dict) (rpn-func * 2 stack)))
               (cons '/ (lambda (stack dict) (rpn-func / 2 stack)))
               (cons '% (lambda (stack dict) (rpn-func modulo 2 stack)))
               (cons '! (lambda (stack dict) (rpn-func fact 1 stack)))
               (cons 'dup (lambda (stack dict) (dup stack)))
               (cons 'swap (lambda (stack dict) (swap stack)))
               (cons 'sin (lambda (stack dict) (rpn-func sin 1 stack)))
               (cons 'cos (lambda (stack dict) (rpn-func cos 1 stack)))
               (cons 'tan (lambda (stack dict) (rpn-func tan 1 stack)))
               (cons 'trunc (lambda (stack dict) (rpn-func truncate 1 stack)))
               (cons 'ceil (lambda (stack dict) (rpn-func ceiling 1 stack)))
               (cons 'floor (lambda (stack dict) (rpn-func floor 1 stack)))
               ;; to be added to init-dict
               (cons 'pow (lambda (stack dict) (rpn-func expt 2 stack)))
               (cons 'log_e (lambda (stack dict) (rpn-func log 1 stack)))
               ;; for log second argument is base
               (cons 'log (lambda (stack dict) (rpn-func log 2 stack)))
               (cons 'sqrt (lambda (stack dict) (rpn-func sqrt 1 stack)))
               (cons 'D (lambda (stack dict) (begin (display stack) (newline) stack)))
               (cons 'rot (lambda (stack dict) (let*-values (((var1 stack) (pop stack))
                                                                                         ((var2 stack) (pop stack))
                                                                                         ((var3 stack) (pop stack)))
                                                                 (let* ((stack (push var1 stack))
                                                                                (stack (push var2 stack)))
                                                                       (push var3 stack)))))
               ))

(define (user-func-from-list func)
 (lambda (stack dict)
       (let loop ((func func)
                          (stack stack))
         (if (= (length func) 1)
               (if (number? (car func))
                 (push (car func) stack)
                 (run-func (car func) dict stack))
               (if (number? (car func))
                 (loop (cdr func) (push (car func) stack))
                 (loop (cdr func) (run-func (car func) dict stack)))))))

(define (new-func list dictionary)
 (insert-into-alist (car list) (user-func-from-list (cdr list)) dictionary))

(define funcs-file "your-funcs")

(define (list-as-string list)
 (parameterize ((current-output-port (open-output-string)))
       (write list)
       (get-output-string (current-output-port))))

(define (add-user-func list user-funcs file)
 (let ((func-to-add (list-as-string list)))
       (parameterize ((current-output-port (open-output-file file)))
         (let ((new-user-funcs (string-append user-funcs func-to-add "\n")))
               (display new-user-funcs)
               (close-output-port (current-output-port))
               new-user-funcs))))

(define (load-funcs-from-file-dict file dict)
 (with-input-from-file file
       (lambda ()
         (let loop ((input (read))
                                (dict dict))
               (if (eof-object? input)
                 dict
                 (loop (read) (new-func input dict)))))))

(define (load-funcs-from-file-str file)
 (with-input-from-file file
       (lambda ()
         (let loop ((next-str (read-string 10))
                                (str ""))
               (if (eof-object? next-str)
                 str
                 (loop (read-string 10) (string-append str next-str)))))))

(let loop ((input (read))
                  (stack '())
                  (dict (load-funcs-from-file-dict funcs-file init-dict))
                  (user-funcs (load-funcs-from-file-str funcs-file)))
 (cond
  ((number? input) (loop (read) (push input stack) dict user-funcs))
  ((list? input) (let ((user-funcs (add-user-func input user-funcs funcs-file)))
                                       (loop (read) stack (new-func input dict) user-funcs)))
  ((symbol? input) (loop (read) (run-func input dict stack) dict user-funcs))
  (else (begin
                  (display "ERROR not valid input: ")
                  (display input)
                  (newline)
                  (loop (read) stack dict)))))

You are viewing proxied material from sdf.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.