;; Full metacircular interpreter for Ruse, written in Ruse

;; This file is a direct translation of
;; full-interpreter-in-scheme.scm into Ruse

;;-----------------------------------------------------------------
;;
;;  <exp> ::= <number>
;;          | <string>
;;          | <variable>
;;          | (quote <exp>)  or '<exp>
;;          | (<exp> <op> <exp>)
;;              where <op> is: + - * / == != < > // % <= >= in
;;          | (with [<var> = <exp>] ... : <exp> ...)
;;          | (if <exp> then <exp> else <exp>)
;;          | (if <exp> then <exp> elif <exp> ... else <exp>)
;;          | (fun (<param> ...) : <exp> ...)
;;          | (<exp> <exp> ...)
;;          | (<var> := <exp>)
;;          | (def <var> <exp>)
;;          | (def (<var> <param> ...) : <exp> ...)
;;          | (do <exp> ...)
;;          | (freeze <exp>)
;;          | (zcons <exp> <exp>)
;;          | (and <exp> <exp> ...)
;;          | (or <exp> <exp> ...)
;;          | (repeat <exp> times : <exp> ...)
;;          | (while <exp> : <exp> ...)
;;
;;----------------------------------------------------------------
;; representation of "frozen" objects (delayed expressions)

(def (make-frozen exp env) :
  (vector 'FROZEN exp env))

(def (frozen? x) :
  (and (vector? x) ((vector-ref x 0) == 'FROZEN)))

(def (get-frozen-exp frozen) :
  (vector-ref frozen 1))

(def (get-frozen-env frozen) :
  (vector-ref frozen 2))

(def (thaw x) :
  (if (frozen? x)
      then (with [computed-value = (m (get-frozen-exp x) (get-frozen-env x))] :
	     (vector-set! x 0 'THAWED)
             (vector-set! x 1 computed-value)
             (vector-set! x 2 'none)
             computed-value)
      elif (thawed? x)
      then (get-computed-value x)
      else x))

(def (thawed? x) :
  (and (vector? x) ((vector-ref x 0) == 'THAWED)))

(def (get-computed-value thawed) :
  (vector-ref thawed 1))

;;-----------------------------------------------------------------

;; removed member? helper function

;; removed before helper function

;; removed after helper function

;;-----------------------------------------------------------------
;; functions for checking syntax and classifying input expressions

;; <number> or <string>
(def (literal-expression? x) :
  (or (number? x) (string? x)))

;; (quote <exp>)
(def (quoted-expression? x) :
  (and (list? x)
       ((length x) == 2)
       ((1st x) == 'quote)))

;; (<exp> <op> <exp>)
(def (infix-expression? x) :
  (and (list? x)
       ((length x) == 3)
       ((2nd x) in '(+ - * / == != < > // % <= >= in))))

;; (if <exp> then <exp> else <exp>)
(def (if-expression? x) :
  (and (list? x)
       ((length x) == 6)
       ((1st x) == 'if)
       ((3rd x) == 'then)
       ((5th x) == 'else)))

;; (if <exp> then <exp> elif <exp> ...)
(def (elif-expression? x) :
  (and (list? x)
       ((length x) > 6)
       ((1st x) == 'if)
       ((3rd x) == 'then)
       ((5th x) == 'elif)
       (check-elif-clauses? (cdr (cdr (cdr (cdr x)))))))

(def (check-elif-clauses? x) :
  (or (and ((length x) == 2)
           ((1st x) == 'else))
      (and ((length x) >= 6)
           ((1st x) == 'elif)
           ((3rd x) == 'then)
	   (or ((5th x) == 'elif)
	       ((5th x) == 'else))
           (check-elif-clauses? (cdr (cdr (cdr (cdr x))))))))

;; (fun (<param> ...) : <exp> ...)
(def (fun-expression? x) :
  (and (list? x)
       ((length x) >= 4)
       ((1st x) == 'fun)
       (list? (2nd x))
       (andmap symbol? (2nd x))
       ((3rd x) == ':)))

;; (<exp> <exp> ...)
(def (application-expression? x) :
  (and (list? x)
       ((length x) >= 1)
       (not (infix-expression? x))
       (not (assignment-statement? x))
       (not (reserved-keyword? (1st x)))))

;; (<var> := <exp>)
(def (assignment-statement? x) :
  (and (list? x)
       ((length x) == 3)
       (symbol? (1st x))
       ((2nd x) == ':=)))

;; (def <var> <exp>)
(def (def-statement? x) :
  (and (list? x)
       ((length x) == 3)
       ((1st x) == 'def)
       (symbol? (2nd x))))
         
;; (do <exp> ...)
(def (do-expression? x) :
  (and (list? x)
       ((length x) >= 2)
       ((1st x) == 'do)))

;; (freeze <exp>)
(def (freeze-expression? x) :
  (and (list? x)
       ((length x) == 2)
       ((1st x) == 'freeze)))

;; (zcons <exp> <exp>)
(def (zcons-expression? x) :
  (and (list? x)
       ((length x) == 3)
       ((1st x) == 'zcons)))

;; (and <exp> <exp> ...)
(def (and-expression? x) :
  (and (list? x)
       ((length x) >= 2)
       ((1st x) == 'and)))

;; (or <exp> <exp> ...)
(def (or-expression? x) :
  (and (list? x)
       ((length x) >= 2)
       ((1st x) == 'or)))

;; (repeat <exp> times : <exp> ...)
(def (repeat-loop? x) :
  (and (list? x)
       ((length x) >= 5)
       ((1st x) == 'repeat)
       ((3rd x) == 'times)
       ((4th x) == ':)))

;; (while <exp> : <exp> ...)
(def (while-loop? x) :
  (and (list? x)
       ((length x) >= 4)
       ((1st x) == 'while)
       ((3rd x) == ':)))

;; (def (<var> <param> ...) : <exp> ...)
(def (def-shorthand? x) :
  (and (list? x)
       ((length x) >= 4)
       ((1st x) == 'def)
       (list? (2nd x))
       (andmap symbol? (2nd x))
       ((length (2nd x)) >= 1)
       ((3rd x) == ':)))

(def (reserved-keyword? x) :
  (x in '(if with fun def do freeze zcons and or repeat while quote)))

;;-----------------------------------------------------------------
;; macro expanders

(def (elif-expander exp) :
  (if (if-expression? exp)
      then exp
      else (with [test-exp = (2nd exp)]
                 [then-exp = (4th exp)]
                 [rest-exps = (after 'elif exp)] :
	     (with [new-else-exp = (cons 'if rest-exps)] :
	       (list 'if test-exp
		     'then then-exp
		     'else (elif-expander new-else-exp))))))

(def (zcons-expander exp) :
  (list 'cons (list 'freeze (2nd exp))
	      (list 'freeze (3rd exp))))

(def (and-expander exp) :
  (with [exp1 = (2nd exp)]
        [rest-exps = (cdr (cdr exp))] :
    (if (null? rest-exps)
	then exp1
	else (with [smaller-and = (cons 'and rest-exps)] :
	       (list 'if exp1
		     'then (and-expander smaller-and)
		     'else 'False)))))

(def (or-expander exp) :
  (with [exp1 = (2nd exp)]
        [rest-exps = (cdr (cdr exp))] :
    (if (null? rest-exps)
	then exp1
	else (with [smaller-or = (cons 'or rest-exps)] :
	       (list 'if exp1
		     'then 'True
		     'else (or-expander smaller-or))))))

(def (def-shorthand-expander exp) :
  (with [name = (1st (2nd exp))]
	[param-list = (cdr (2nd exp))]
	[body-list = (after ': exp)] :
    (list 'def name
	  (cons 'fun (cons param-list (cons ': body-list))))))

;;-----------------------------------------------------------------
;; (with [<var> = <exp>] ... : <exp> ...)

(def (with-expression? x) :
  (and (list? x)
       ((length x) >= 4)
       ((1st x) == 'with)
       (': in x)
       ((length (after ': x)) >= 1)
       (andmap binding? (get-with-bindings x))))

(def (binding? x) :
  (and (list? x)
       ((length x) == 3)
       (symbol? (1st x))
       ((2nd x) == '=)))

(def (get-with-bindings exp) :
  (cdr (before ': exp)))

(def (get-with-vars exp) :
  (map (fun (b) : (1st b)) (get-with-bindings exp)))

(def (get-with-exps exp) :
  (map (fun (b) : (3rd b)) (get-with-bindings exp)))

(def (get-with-body-exps exp) :
  (after ': exp))

;;-----------------------------------------------------------------
;; interpreter

(def (run exp) :
  (m exp (make-fresh-initial-environment)))

(def (m exp env) :
  (if ;; <number> or <string>
      (literal-expression? exp) then exp

      ;; <variable>
      elif (symbol? exp) then (lookup-value exp env)

      ;; (quote <exp>)
      elif (quoted-expression? exp) then (2nd exp)

      ;; (<exp> <op> <exp>)
      elif (infix-expression? exp)
      then (with [value1 = (m (1st exp) env)]
		 [value2 = (m (3rd exp) env)]
		 [op = (2nd exp)] :
	     (if (op == '+) then (value1 + value2)
		 elif (op == '-) then (value1 - value2)
		 elif (op == '*) then (value1 * value2)
		 elif (op == '/) then (value1 / value2)
		 elif (op == '<) then (value1 < value2)
		 elif (op == '>) then (value1 > value2)
		 elif (op == '==) then (value1 == value2)
		 elif (op == '!=) then (value1 != value2)
		 elif (op == '//) then (value1 // value2)
		 elif (op == '%) then (value1 % value2)
		 elif (op == '<=) then (value1 <= value2)
		 elif (op == '>=) then (value1 >= value2)
		 elif (op == 'in) then (and (list? value2) (value1 in value2))
		 else (error "unknown operator:" op)))

      ;; (if <exp> then <exp> else <exp>)
      elif (if-expression? exp)
      then (with [condition-exp = (2nd exp)]
		 [consequent-exp = (4th exp)]
		 [alternative-exp = (6th exp)] :
	     (with [condition-value = (m condition-exp env)] :
	       (if (condition-value == True)
		   then (m consequent-exp env)
		   else (m alternative-exp env))))

      ;; (with [<var> = <exp>] ... : <exp> ...)
      elif (with-expression? exp)
      then (with [vars-list = (get-with-vars exp)]
		 [exps-list = (get-with-exps exp)]
		 [body-list = (get-with-body-exps exp)] :
	     (with [vals-list = (map (fun (x) : (m x env)) exps-list)] :
	       (with [new-env = (extend vars-list vals-list env)] :
		 (m-sequential body-list new-env))))

      ;; (fun (<param> ...) : <exp> ...)
      elif (fun-expression? exp)
      then (with [params-list = (2nd exp)]
		 [body-list = (after ': exp)] :
	     (fun (args-list) :
	       (if ((length args-list) == (length params-list))
		   then (with [new-env = (extend params-list args-list env)] :
			  (m-sequential body-list new-env))
		   else (error "wrong number of arguments"))))

      ;; function applications
      ;; (<exp> <exp> ...)
      elif (application-expression? exp)
      then (with [operator-exp = (1st exp)]
		 [operands-list = (cdr exp)] :
	     (with [function = (m operator-exp env)]
		   [args-list = (map (fun (x) : (m x env)) operands-list)] :
	       (function args-list)))

      ;; (<var> := <exp>)
      elif (assignment-statement? exp)
      then (with [var = (1st exp)]
		 [right-side-exp = (3rd exp)] :
	     (with [new-value = (m right-side-exp env)]
		   [memory-ref = (lookup-ref var env)] :
	       (set-contents! memory-ref new-value)
               'done))

      ;; (def <var> <exp>)
      elif (def-statement? exp)
      then (with [var = (2nd exp)]
		 [right-side-exp = (3rd exp)] :
	     (with [new-value = (m right-side-exp env)]
		   [memory-ref = (lookup-ref-in-first-frame var env)] :
	       (set-contents! memory-ref new-value)
               'done))

      ;; (do <exp> ...)
      elif (do-expression? exp)
      then (with [exps-list = (cdr exp)] :
	     (m-sequential exps-list env))

      ;; (freeze <exp>)
      elif (freeze-expression? exp) then (make-frozen (2nd exp) env)

      ;; (repeat <exp> times : <exp> ...)
      elif (repeat-loop? exp)
      then (with [count-exp = (2nd exp)]
		 [body-list = (after ': exp)] :
	     (repeat (m count-exp env) times :
	       (m-sequential body-list env)))

      ;; (while <exp> : <exp> ...)
      elif (while-loop? exp)
      then (with [condition-exp = (2nd exp)]
		 [body-list = (after ': exp)] :
	     (while ((m condition-exp env) == True) :
	       (m-sequential body-list env)))

      ;; macros:

      ;; (if <exp> then <exp> elif <exp> then ...)
      elif (elif-expression? exp) then (m (elif-expander exp) env)

      ;; (zcons <exp> <exp>)
      elif (zcons-expression? exp) then (m (zcons-expander exp) env)

      ;; (and <exp> <exp> ...)
      elif (and-expression? exp) then (m (and-expander exp) env)

      ;; (or <exp> <exp> ...)
      elif (or-expression? exp) then (m (or-expander exp) env)

      ;; (def (<var> <param> ...) : <exp> ...)
      elif (def-shorthand? exp) then (m (def-shorthand-expander exp) env)

      else (error "invalid expression:" exp)))


;; removed evaluate-repeat-loop helper function

;; removed evaluate-while-loop helper function

(def (m-sequential exps-list env) :
  (if (null? (cdr exps-list))
      then (m (1st exps-list) env)
      else (do (m (1st exps-list) env)
               (m-sequential (cdr exps-list) env))))

;;-----------------------------------------------------------------
;; read-eval-print driver loop

(def (start) :
  (display "Welcome to the SLC Meta-Circular Ruse Interpreter\n\n")
  (initial-env := (make-fresh-initial-environment))
  (read-eval-print-loop initial-env))

(def (restart) :
  (display "Restarting...\n")
  (read-eval-print-loop initial-env))

(def (read-eval-print-loop env) :
  (display "(META)==> ")
  (with [input-expression = (read)] :
    (if (input-expression == 'quit)
	then 'Goodbye!
	else (with [result = (m input-expression env)] :
	       (display (make-printable result))
               (newline)
               (read-eval-print-loop env)))))

(def (make-printable x) :
  (if (procedure? x)
      then '<function>
      elif (frozen? x)
      then '<frozen>
      elif (thawed? x)
      then (make-printable (get-computed-value x))
      elif (list? x)
      then (map make-printable x)
      elif (pair? x)
      then (cons (make-printable (car x)) (make-printable (cdr x)))
      else x))

;;-----------------------------------------------------------------
;; representation of memory references as 1-element vectors

(def (make-memory-ref x) :
  (vector x))

(def (deref ref) :
  (vector-ref ref 0))

(def (set-contents! ref new-val) :
  (vector-set! ref 0 new-val))

;;----------------------------------------------------------------------
;; environments

(def (extend vars vals env) :
  (with [refs = (map make-memory-ref vals)] :
    (with [new-frame = (list vars refs)] :
      (cons (make-memory-ref new-frame) env))))

(def (first-frame-vars env) :
  (1st (deref (1st env))))

(def (first-frame-refs env) :
  (2nd (deref (1st env))))

(def (retrieve var frame-vars frame-refs) :
  (if ((1st frame-vars) == var)
      then (1st frame-refs)
      else (retrieve var (cdr frame-vars) (cdr frame-refs))))

(def (lookup-ref var env) :
  (if (null? env)
      then (error "unknown value for variable:" var)
      elif (var in (first-frame-vars env))
      then (retrieve var (first-frame-vars env) (first-frame-refs env))
      else (lookup-ref var (cdr env))))

(def (lookup-ref-in-first-frame var env) :
  (if (null? env)
      then (error "unknown value for variable:" var)
      elif (var in (first-frame-vars env))
      then (retrieve var (first-frame-vars env) (first-frame-refs env))
      else (with [new-ref = (make-memory-ref 'none)] :
	     (extend-first-frame! env var new-ref)
             new-ref)))

(def (extend-first-frame! env new-var new-ref) :
  (with [new-frame = (list (cons new-var (first-frame-vars env))
                           (cons new-ref (first-frame-refs env)))] :
    (set-contents! (1st env) new-frame)))

(def (lookup-value var env) :
  (if (var == 'current-env)
      then env
      else (deref (lookup-ref var env))))

(def empty-env nil)

;;-----------------------------------------------------------------
;; the initial environment

(def (make-fresh-initial-environment) :
  (extend (list 'a 'b 'c 'd 'pi 'True 'False 'nil 'cons 'car 'cdr 'null? 'list
		'square 'squareroot 'minus 'average 'print 'load 'random
		'thaw 'zcar 'zcdr
		;; new primitives
	        'not 'number? 'string? 'symbol? 'list? 'vector? 'procedure?
		'pair? 'length 'display 'newline 'eof-object? 'open-input-file
		'close-input-port '1st '2nd '3rd '4th '5th '6th 'before 'after
		'vector-ref 'vector-set! 'vector 'read 'error 'map 'andmap)
          (list 1 2 3 4 3.141592653589793 True False nil
                ;; cons
                (fun (args-list) :
		  (with [x = (1st args-list)]
                        [y = (2nd args-list)] :
		    (cons x y)))
                ;; car
                (fun (args-list) :
		  (with [x = (1st args-list)] :
		    (car x)))
                ;; cdr
                (fun (args-list) :
		  (with [x = (1st args-list)] :
		    (cdr x)))
                ;; null?
                (fun (args-list) :
		  (with [x = (1st args-list)] :
		    (null? x)))
                ;; list
                (fun (args-list) :
		  args-list)
                ;; square
                (fun (args-list) :
		  (with [n = (1st args-list)] :
		    (n * n)))
		;; squareroot
                (fun (args-list) :
		  (with [n = (1st args-list)] :
		    (squareroot n)))
                ;; minus
                (fun (args-list) :
		  (with [n = (1st args-list)] :
		    (n * -1)))
                ;; average
                (fun (args-list) :
		  (with [x = (1st args-list)]
                        [y = (2nd args-list)] :
		    ((x + y) / 2)))
                ;; print
                (fun (args-list) :
		  (print-values args-list))
		;; load
                (fun (args-list) :
		  (with [filename = (1st args-list)] :
		    (if (not (string? filename))
			then (error "filename must be a string")
			else (with [port = (open-input-file filename)] :
			       (load-loop port)))))
		;; random
		(fun (args-list) :
		  (with [x = (1st args-list)] :
		    (random x)))
                ;; thaw
                (fun (args-list) :
		  (with [x = (1st args-list)] :
		    (thaw x)))
                ;; zcar
                (fun (args-list) :
		  (with [x = (1st args-list)] :
		    (thaw (car x))))
                ;; zcdr
                (fun (args-list) :
		  (with [x = (1st args-list)] :
		    (thaw (cdr x))))
		;; new primitives
		(fun (args-list) : (not (1st args-list)))
		(fun (args-list) : (number? (1st args-list)))
		(fun (args-list) : (string? (1st args-list)))
		(fun (args-list) : (symbol? (1st args-list)))
		(fun (args-list) : (list? (1st args-list)))
		(fun (args-list) : (vector? (1st args-list)))
		(fun (args-list) : (procedure? (1st args-list)))
		(fun (args-list) : (pair? (1st args-list)))
		(fun (args-list) : (length (1st args-list)))
		(fun (args-list) : (display (1st args-list)))
		(fun (args-list) : (newline))
		(fun (args-list) : (eof-object? (1st args-list)))
		(fun (args-list) : (open-input-file (1st args-list)))
		(fun (args-list) : (close-input-port (1st args-list)))
		(fun (args-list) : (1st (1st args-list)))
		(fun (args-list) : (2nd (1st args-list)))
		(fun (args-list) : (3rd (1st args-list)))
		(fun (args-list) : (4th (1st args-list)))
		(fun (args-list) : (5th (1st args-list)))
		(fun (args-list) : (6th (1st args-list)))
		(fun (args-list) : (before (1st args-list) (2nd args-list)))
		(fun (args-list) : (after (1st args-list) (2nd args-list)))
		(fun (args-list) : (vector-ref (1st args-list) (2nd args-list)))
		(fun (args-list) : (vector-set! (1st args-list) (2nd args-list) (3rd args-list)))
		;; vector (takes 1, 2 or 3 arguments)
		(fun (args-list) :
		  (with [len = (length args-list)] :
		    (if (len == 1)
			then (vector (1st args-list))
			elif (len == 2)
			then (vector (1st args-list) (2nd args-list))
			elif (len == 3)
			then (vector (1st args-list) (2nd args-list) (3rd args-list))
			else (error "vector called with wrong number of arguments"))))
		;; read (takes 0 or 1 arguments)
		(fun (args-list) :
		  (with [len = (length args-list)] :
		    (if (len == 0)
			then (read)
			elif (len == 1)
			then (read (1st args-list))
			else (error "read called with wrong number of arguments"))))
		;; error (takes 1 or 2 arguments)
		(fun (args-list) :
		  (with [len = (length args-list)] :
		    (if (len == 1)
			then (error (1st args-list))
			elif (len == 2)
			then (error (1st args-list) (2nd args-list))
			else (error "error called with wrong number of arguments"))))
		;; map
		(fun (args-list) :
		  (with [function = (1st args-list)] ;; this is a Ruse function
			[ls = (2nd args-list)] :
		    (map (fun (x) : (function (list x))) ls)))
		;; andmap
		(fun (args-list) :
		  (with [function = (1st args-list)] ;; this is a Ruse function
			[ls = (2nd args-list)] :
		    (andmap (fun (x) : (function (list x))) ls)))
                )
          empty-env))

(def (print-values args-list) :
  (if (null? args-list)
      then (do (newline) 'done)
      else (do (display (make-printable (1st args-list)))
               (display " ")
	       (print-values (cdr args-list)))))

(def (load-loop port) :
  (with [input-expression = (read port)] :
    (if (eof-object? input-expression)
	then (do (close-input-port port) 'done)
	else (do (m input-expression initial-env)
		 (load-loop port)))))

(def initial-env (make-fresh-initial-environment))