MUPL - Made Up Programming Language

;; Programming Languages, Homework 5

#lang racket
(provide (all-defined-out)) ;; so we can put tests in a second file

;; definition of structures for MUPL programs - Do NOT change
(struct var  (string) #:transparent)  ;; a variable, e.g., (var "foo")
(struct int  (num)    #:transparent)  ;; a constant number, e.g., (int 17)
(struct add  (e1 e2)  #:transparent)  ;; add two expressions
(struct ifgreater (e1 e2 e3 e4)    #:transparent) ;; if e1 > e2 then e3 else e4
(struct fun  (nameopt formal body) #:transparent) ;; a recursive(?) 1-argument function
(struct call (funexp actual)       #:transparent) ;; function call
(struct mlet (var e body) #:transparent) ;; a local binding (let var = e in body) 
(struct apair (e1 e2)     #:transparent) ;; make a new pair
(struct fst  (e)    #:transparent) ;; get first part of a pair
(struct snd  (e)    #:transparent) ;; get second part of a pair
(struct aunit ()    #:transparent) ;; unit value -- good for ending a list
(struct isaunit (e) #:transparent) ;; evaluate to 1 if e is unit else 0

;; a closure is not in "source" programs; it is what functions evaluate to
(struct closure (env fun) #:transparent) 

;; Helper function for debugging
(define (println . args)
  (for-each (lambda (arg)
              (display arg)
              (display " "))
            args)
  (newline))

;; Problem 1

(define (racketlist->mupllist xs)
  (if (null? xs)
      (aunit)
      (apair (first xs) (racketlist->mupllist (list-tail xs 1)))))

(define (mupllist->racketlist ml)  
  (cond [(aunit? ml) '()]
        [(apair? ml) (cons (apair-e1 ml) (mupllist->racketlist (apair-e2 ml)))]))

;; Problem 2

;; lookup a variable in an environment
;; Do NOT change this function
(define (envlookup env str)
  (cond [(null? env) (error "unbound variable during evaluation" str)]
        [(equal? (car (car env)) str) (cdr (car env))]
        [#t (envlookup (cdr env) str)]))

;; Do NOT change the two cases given to you.  
;; DO add more cases for other kinds of MUPL expressions.
;; We will test eval-under-env by calling it directly even though
;; "in real life" it would be a helper function of eval-exp.
(define (eval-under-env e env)
  (cond [(var? e) 
         (envlookup env (var-string e))]
	[(int? e) e]
	[(integer? e) e] ;; Racket Primitive, to pass some weird test cases I've seen, though I don't think this should be here.
	[(aunit? e) e]
        [(add? e) 
         (let ([v1 (eval-under-env (add-e1 e) env)]
               [v2 (eval-under-env (add-e2 e) env)])
           (if (and (int? v1)
                    (int? v2))
               (int (+ (int-num v1) 
                       (int-num v2)))
               (error "MUPL addition applied to non-number")))]
	[(fun? e) (closure env e)]
	[(closure? e) e]
	[(ifgreater? e)
	 (let ([v1 (eval-under-env (ifgreater-e1 e) env)]
	       [v2 (eval-under-env (ifgreater-e2 e) env)])
	   (if (and (int? v1) (int? v2))
	       (cond [(> (int-num v1) (int-num v2)) (eval-under-env (ifgreater-e3 e) env)]
		     [#t (eval-under-env (ifgreater-e4 e) env)])
	       (error "MUPL ifgreater evaluated to non-number")))]
	[(mlet? e)
	 (let ([v (eval-under-env (mlet-e e) env)])
	   (eval-under-env (mlet-body e) (append (list (cons (mlet-var e) v))
						 env)))]
	[(call? e)
	 (let ([v1 (eval-under-env (call-funexp e) env)]
	       [v2 (eval-under-env (call-actual e) env)])
	   (if (closure? v1) 
	       (eval-under-env (fun-body (closure-fun v1))
			       (append (closure-env v1)
				       (list (cons (fun-formal (closure-fun v1)) v2)
                                             (if (fun-nameopt (closure-fun v1))
                                                 (cons (fun-nameopt (closure-fun v1)) v1)
                                                 '()))))
	       (error "First argument to call should evaluate to a closure!")))]
	[(apair? e)
	 (let ([v1 (eval-under-env (apair-e1 e) env)]
	       [v2 (eval-under-env (apair-e2 e) env)])
	   (apair v1 v2))]
	[(fst? e)
	 (let ([v (eval-under-env (fst-e e) env)])
	   (if (apair? v)
	       (apair-e1 v)
	       (error "fst applied to non-pair")))]
	[(snd? e)
	 (let ([v (eval-under-env (snd-e e) env)])
	   (if (apair? v)
	       (apair-e2 v)
	       (error "snd applied to non-pair")))]
	[(isaunit? e) (let ([v (eval-under-env (isaunit-e e) env)])
			(if (aunit? v)
			    (int 1)
			    (int 0)))]
	[#t (error "bad MUPL expression")]))

;; Do NOT change
(define (eval-exp e)
  (eval-under-env e null))
        
;; Problem 3

(define (ifaunit e1 e2 e3)
  (ifgreater (isaunit e1) (int 0) e2 e3))

(define (mlet* lst e2)
  (if (null? lst)
      e2
      (let ([v (first lst)])
	(mlet (car v) (cdr v) (mlet* (cdr lst) e2)))))
 
(define (ifeq e1 e2 e3 e4)
  ;; Using a macro inside a macro!
  (mlet* (list (cons "_x" e1) (cons "_y" e2))
	 (ifgreater (var "_x") (var "_y") e4
		    (ifgreater (var "_y") (var "_x") e4 e3))))

;; Problem 4
(define mupl-map
 (fun "map-fun" "fn"
      (fun "map-lst" "lst"
	   (ifeq (isaunit (var "lst")) (int 1)
		 (aunit)
		 (apair (call (var "fn") (fst (var "lst")))
			(call (var "map-lst") (snd (var "lst"))))))))


(define mupl-mapAddN 
  (mlet "map" mupl-map
	(fun "mupl-fun-int" "i"
	     (fun "mupl-fun-list" "ml-int"
		  (call (call (var "map") (fun "add-i" "x" (add (var "x") (var "i"))))
			(var "ml-int"))))))

;; Challenge Problem

(struct fun-challenge (nameopt formal body freevars) #:transparent) ;; a recursive(?) 1-argument function

;; We will test this function directly, so it must do
;; as described in the assignment

; I think you can ask "for any given expression, how do I know what the free
; variables of this expression are, if I could compute all the free vars of the
; sub expressions. There are a couple ways to
; go.  Think the simplest way would be to separate out the recursion that finds
; the funs to turn into fun-challenge from the computation of the free vars
; that go into fun challenge
; as in - walk the tree… oh here's a fun.  let me compute the set of free vars from the body….  
; ok - now I can make the fun-challenge… continue walking

(define (compute-free-vars e)
  (letrec ((free-vars (lambda (e var-set)
			;; TODO: set is void in recursive calls. Why? 
			;(println "var-set: " var-set)
			(cond [(var? e) (set e)] ;; TODO: Ignore vars that are fun-nameopt or fun-formal.
			      [(fun? e) (free-vars fun-body var-set)]
			      [(mlet? e) (free-vars mlet-body var-set)] ;; Same thing with mlet vars.
			      [(add? e) (set-union
					 (free-vars add-e1 var-set)
					 (free-vars add-e2 var-set))]
			      [(ifgreater? e) (set-union
					       (free-vars ifgreater-e1 var-set)
					       (free-vars ifgreater-e2 var-set)
					       (free-vars ifgreater-e3 var-set)
					       (free-vars ifgreater-e4 var-set))]
			      )) ))
    (free-vars e (set))))

;; Do NOT share code with eval-under-env because that will make
;; auto-grading and peer assessment more difficult, so
;; copy most of your interpreter here and make minor changes
(define (eval-under-env-c e env) "CHANGE")

;; Do NOT change this
(define (eval-exp-c e)
  (eval-under-env-c (compute-free-vars e) null))

❤️