https://www.coursera.org/learn/programming-languages-part-b/home

B站搬运：

https://www.bilibili.com/video/BV1tZ4y1D7

### 说明

(struct apair (e1 e2)     #:transparent)

apair?
apair-e1
apair-e2

### 代码

;; 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 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 but /is/ a MUPL value; it is what functions evaluate to
(struct closure (env fun) #:transparent)

;; Problem 1
(define (racketlist->mupllist racket-list)
(if (null? racket-list)
(aunit)
(apair (car racket-list) (racketlist->mupllist (cdr racket-list)))))

;; Problem 2
(define (mupllist->racketlist mupl-list)
(if (aunit? mupl-list)
null
(cons (apair-e1 mupl-list) (mupllist->racketlist (apair-e2 mupl-list)))))

;; 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))]
(let ([v1 (eval-under-env (add-e1 e) env)]
(if (and (int? v1)
(int? v2))
(int (+ (int-num v1)
(int-num v2)))
(error "MUPL addition applied to non-number")))]
;; CHANGE add more cases here
[(int? 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))
(if (> (int-num v1) (int-num v2))
(eval-under-env (ifgreater-e3 e) env)
(eval-under-env (ifgreater-e4 e) env))
(error "MUPL ifgreater applied to non-number")))]
[(fun? e) (closure env e)]
[(call? e)
(let ([funexp (eval-under-env (call-funexp e) env)]
[actual (eval-under-env (call-actual e) env)])
(if (closure? funexp)
(let ([funenv (closure-env funexp)]
[func (closure-fun funexp)]
; 在当前env评估参数
[v (eval-under-env actual env)])
(let* ([name (fun-nameopt func)]
[formal (fun-formal func)]
[body (fun-body func)]
[funenv (cons (cons formal v) funenv)])
(if name
(let ([funenv (cons (cons name funexp) funenv)])
(eval-under-env body funenv))
(eval-under-env body funenv))))
(error "MUPL call? applied to non-closure")))]
[(mlet? e)
(let ([v (eval-under-env (mlet-e e) env)])
(eval-under-env (mlet-body e) (cons (cons (mlet-var e) v) env)))]
[(apair? e)
(apair (eval-under-env (apair-e1 e) env) (eval-under-env (apair-e2 e) env))]
[(fst? e)
(let ([e (eval-under-env (fst-e e) env)])
(if (apair? e)
(apair-e1 e)
(error "MUPL fst applied to non-apair")))]
[(snd? e)
(let ([e (eval-under-env (snd-e e) env)])
(if (apair? e)
(apair-e2 e)
(error "MUPL snd applied to non-apair")))]
[(isaunit? e)
(let ([v (eval-under-env (isaunit-e e) env)])
(if (aunit? v)
(int 1)
(int 0)))]
[(closure? e) e]
[(int? e) e]
[(aunit? e) e]
[#t (error (format "bad MUPL expression: ~v" e))]))

;; 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* lstlst e2)
(if (null? lstlst)
e2
(let* ([pair (car lstlst)])
(mlet (car pair) (cdr pair) (mlet* (cdr lstlst) e2)))))

(define (ifeq e1 e2 e3 e4)
(mlet* (list (cons "_x" e1) (cons "_y" e2))
(ifgreater (var "_x") (var "_y")
e4
(ifgreater (var "_y") (var "_x") e4 e3))))

;; Problem 4
; https://github.com/houxianxu/programming-language-coursera/blob/master/hw5-section6/hw5-houxianxu.rkt
(define mupl-map
(fun #f "fun"
(fun "map" "lstlst"
(ifaunit (var "lstlst")
(aunit)
(apair (call (var "fun") (fst (var "lstlst")))
(call (var "map") (snd (var "lstlst"))))))))

(mlet "map" mupl-map
(fun #f "n"
(call (var "map") (fun #f "x" (add (var "x") (var "n")))))))

;; 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
(struct pair (expr fvar) #:transparent)

(define (compute-free-vars e)
(define (f e)
(cond [(var? e) (pair e (set (var-string e)))]
(pair (add (pair-expr e1) (pair-expr e2))
(set-union (pair-fvar e1) (pair-fvar e2))))]
;; CHANGE add more cases here
[(int? e) (pair e (set))]
[(ifgreater? e)
(let ([e1 (f (ifgreater-e1 e))]
[e2 (f (ifgreater-e2 e))]
[e3 (f (ifgreater-e3 e))]
[e4 (f (ifgreater-e4 e))])
(pair (ifgreater (pair-expr e1) (pair-expr e2) (pair-expr e3) (pair-expr e4))
(set-union (pair-fvar e1) (pair-fvar e2) (pair-fvar e3) (pair-fvar e4))))]
[(fun? e)
(let* ([fun-pair (f (fun-body e))]
; 总的free-vars减去参数
[free-vars (set-remove (pair-fvar fun-pair) (fun-formal e))]
; 删除函数名
[free-vars (if (fun-nameopt e) (set-remove free-vars (fun-nameopt e)) free-vars)])
(pair (fun-challenge (fun-nameopt e) (fun-formal e) (pair-expr fun-pair) free-vars)
free-vars))]
[(call? e)
(let ([e1 (f (call-funexp e))]
[e2 (f (call-actual e))])
(pair (call (pair-expr e1) (pair-expr e2))
(set-union (pair-fvar e1) (pair-fvar e2))))]
[(mlet? e)
(let ([e1 (f (mlet-e e))]
[e2 (f (mlet-body e))])
(pair (mlet (mlet-var e) (pair-expr e1) (pair-expr e2))
; 删除let中变量
(set-union (pair-fvar e1) (set-remove (pair-fvar e2) (mlet-var e)))))]
[(apair? e)
(let ([e1 (f (apair-e1 e))]
[e2 (f (apair-e2 e))])
(pair (apair (pair-expr e1) (pair-expr e2))
(set-union (pair-fvar e1) (pair-fvar e2))))]
[(fst? e)
(let ([e1 (f (fst-e e))])
(pair (fst (pair-expr e1)) (pair-fvar e1)))]
[(snd? e)
(let ([e1 (f (snd-e e))])
(pair (snd (pair-expr e1)) (pair-fvar e1)))]
[(isaunit? e)
(let ([e1 (f (isaunit-e e))])
(pair (isaunit (pair-expr e1)) (pair-fvar e1)))]
[(int? e) (pair e (set))]
[(aunit? e) (pair e (set))]
[(closure? e)
(let ([e1 (f (closure-env e))]
[e2 (f (closure-fun e))])
(pair (closure e (pair-expr e2))
(pair-fvar e2)))]))
(pair-expr (f e)))

;; 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)
(cond [(var? e)
(envlookup env (var-string e))]
(let ([v1 (eval-under-env-c (add-e1 e) env)]
(if (and (int? v1)
(int? v2))
(int (+ (int-num v1)
(int-num v2)))
(error "MUPL addition applied to non-number")))]
;; CHANGE add more cases here
[(int? e) e]
[(ifgreater? e)
(let ([v1 (eval-under-env-c (ifgreater-e1 e) env)]
[v2 (eval-under-env-c (ifgreater-e2 e) env)])
(if (and (int? v1)
(int? v2))
(if (> (int-num v1) (int-num v2))
(eval-under-env-c (ifgreater-e3 e) env)
(eval-under-env-c (ifgreater-e4 e) env))
(error "MUPL ifgreater applied to non-number")))]
[(fun-challenge? e)
; 添加到env中
(closure (set-map (fun-challenge-freevars e) (lambda (s) (cons s (envlookup env s)))) e)]
[(call? e)
(let ([funexp (eval-under-env-c (call-funexp e) env)]
[actual (eval-under-env-c (call-actual e) env)])
(if (closure? funexp)
(let ([funenv (closure-env funexp)]
[func (closure-fun funexp)]
; 在当前env评估参数
[v (eval-under-env-c actual env)])
(let* ([name (fun-challenge-nameopt func)]
[formal (fun-challenge-formal func)]
[body (fun-challenge-body func)]
[funenv (cons (cons formal v) funenv)])
(if name
(let ([funenv (cons (cons name funexp) funenv)])
(eval-under-env-c body funenv))
(eval-under-env-c body funenv))))
(error "MUPL call? applied to non-closure")))]
[(mlet? e)
(let ([v (eval-under-env-c (mlet-e e) env)])
(eval-under-env-c (mlet-body e) (cons (cons (mlet-var e) v) env)))]
[(apair? e)
(apair (eval-under-env-c (apair-e1 e) env) (eval-under-env-c (apair-e2 e) env))]
[(fst? e)
(let ([e (eval-under-env-c (fst-e e) env)])
(if (apair? e)
(apair-e1 e)
(error "MUPL fst applied to non-apair")))]
[(snd? e)
(let ([e (eval-under-env-c (snd-e e) env)])
(if (apair? e)
(apair-e2 e)
(error "MUPL snd applied to non-apair")))]
[(isaunit? e)
(let ([v (eval-under-env-c (isaunit-e e) env)])
(if (aunit? v)
(int 1)
(int 0)))]
[(closure? e) e]
[(int? e) e]
[(aunit? e) e]
[#t (error (format "bad MUPL expression: ~v" e))]))

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

; (define eval-exp eval-exp-c)

### 测试

#lang racket
;; Programming Languages Homework 5 Simple Test
;; Save this file to the same directory as your homework file
;; These are basic tests. Passing these tests does not guarantee that your code will pass the actual homework grader

;; Be sure to put your homework file in the same folder as this test file.
;; Uncomment the line below and, if necessary, change the filename
;;(require "hw5")

(require rackunit)

(define tests
(test-suite
"Sample tests for Assignment 5"

;; check racketlist to mupllist with normal list
(check-equal? (racketlist->mupllist (list (int 3) (int 4))) (apair (int 3) (apair (int 4) (aunit))) "racketlist->mupllist test")
(check-equal? (racketlist->mupllist null) (aunit) "racketlist->mupllist test")

;; check mupllist to racketlist with normal list
(check-equal? (mupllist->racketlist (apair (int 3) (apair (int 4) (aunit)))) (list (int 3) (int 4)) "mupllist->racketlist test")

;; tests if ifgreater returexp (mlet "x" (int 1) (add (int 5) (var "x")))) (int 6) "mlet test")

;; callns (int 2)
(check-equal? (eval-exp (ifgreater (int 3) (int 4) (int 3) (int 2))) (int 2) "ifgreater test")

;; mlet test
(check-equal? (eval-exp (call (closure '() (fun #f "x" (add (var "x") (int 7)))) (int 1))) (int 8) "call test")

;;fst test
(check-equal? (eval-exp (fst (apair (int 1) (int 2)))) (int 1) "fst test")

;;snd test
(check-equal? (eval-exp (snd (apair (int 1) (int 2)))) (int 2) "snd test")

;; isaunit test
(check-equal? (eval-exp (isaunit (closure '() (fun #f "x" (aunit))))) (int 0) "isaunit test")

;; ifaunit test
(check-equal? (eval-exp (ifaunit (int 1) (int 2) (int 3))) (int 3) "ifaunit test")

;; mlet* test
(check-equal? (eval-exp (mlet* (list (cons "x" (int 10))) (var "x"))) (int 10) "mlet* test")

;; ifeq test
(check-equal? (eval-exp (ifeq (int 1) (int 2) (int 3) (int 4))) (int 4) "ifeq test")

;; mupl-map test
(check-equal? (eval-exp (call (call mupl-map (fun #f "x" (add (var "x") (int 7)))) (apair (int 1) (aunit))))
(apair (int 8) (aunit)) "mupl-map test")

;; problems 1, 2, and 4 combined test
(check-equal? (mupllist->racketlist
(eval-exp (call (call mupl-mapAddN (int 7))
(racketlist->mupllist
(list (int 3) (int 4) (int 9)))))) (list (int 10) (int 11) (int 16)) "combined test")

))

(require rackunit/text-ui)
;; runs the test
(run-tests tests)


13 success(es) 0 failure(s) 0 error(s) 13 test(s) run