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))

Dear mgill25, could you please delete this Gist? You are giving away the solution to a graded assignment in the Coursera "Programming Languages" Course (which is currently offered again in self-paced mode). This makes it very easy to cheat and reduces the learning effect for other learners. Many thanks in advance for your collaboration in making the course more effective for everyone!

❤️