Programming Language Part B Module 6 Extra Practice Problems

Extra Practice Problem for Module 6

#lang racket
(provide (all-defined-out))

(struct btree-leaf () #:transparent)
(struct btree-node (value left right) #:transparent)

; Q1
(define (tree-height t)
  (if (btree-leaf? t)
      0
      (+ 1 (max (tree-height (btree-node-left t)) (tree-height (btree-node-right t))))))

; Q2
(define (sum-tree t)
  (if (btree-leaf? t)
      0
      ( + (btree-node-value t) (+ (sum-tree (btree-node-left t)) (sum-tree (btree-node-right t))))))

; Q3
(define (prune-at-v t v)
  (if (btree-node? t)
      (if (equal? (btree-node-value t) v)
          (btree-leaf)
          (btree-node (btree-node-value t)
                      (prune-at-v (btree-node-left t) v)
                      (prune-at-v (btree-node-right t) v)))
      (btree-leaf)))

; Q4
(define (well-formed-tree? t)
  (if (btree-leaf? t)
      #t
      (if (btree-node? t)
          (and #t (well-formed-tree? (btree-node-left t)) (well-formed-tree? (btree-node-right t)))
          #f)))

; Q5
(define (fold-tree f acc t)
  (if (btree-leaf? t)
      acc
      (let* (
             [v (f acc (btree-node-value t))]
             [v (fold-tree f v (btree-node-left t))]
             [v (fold-tree f v (btree-node-right t))])
        v)))

; Q6
(define (fold-tree-curried)
  (lambda (f)
    (lambda (acc)
      (lambda (t)
        (if (btree-leaf? t)
            acc
            (let* ([v (f acc (btree-node-value t))]
                   [v ((((fold-tree-curried) f) v) (btree-node-left t))]
                   [v ((((fold-tree-curried) f) v) (btree-node-right t))])
              v))))))

; Q7
(define (crazy-sum lst)
  (letrec ([f (lambda (prev acc operator lst)
                (cond [(null? lst) acc]
                      [(and (number? prev) (number? (car lst))) (f (car lst) (+ acc (car lst)) + (cdr lst))]
                      [(number? (car lst)) (f (car lst) (operator acc (car lst)) operator (cdr lst) )]
                      [#t (f (car lst) acc (car lst) (cdr lst))]))])
    (f 0 0 + lst)))

; Q8
(define (fold-list f acc arr)
  (cond [(null? arr) acc]
        [#t (fold-list f (f acc (car arr)) (cdr arr))]))

(define (either-fold f acc data)
  (cond [(list? data) (fold-list f acc data)]
        [(or (btree-leaf? data) (btree-node? data)) (fold-tree f acc data)]
        [#t (error "neither list or tree")]
   ))

; Q9
(define (flatten lst)
  (
   cond [(null? lst) lst]
        [(list? (car lst)) (flatten (append (flatten (car lst)) (flatten (cdr lst))))]
        [#t (cons (car lst) (flatten (cdr lst)))]
   ))

; Q10
(define (remove-lets e)
  (cond [(var? e) 
         e]
        [(int? e) e]
        [(add? e) 
         (let ([v1 (remove-lets(add-e1 e))]
               [v2 (remove-lets(add-e2 e))])
           (add v1 v2))]
        [(ifgreater? e) (
                         let ([v1 (remove-lets (ifgreater-e1 e) )]
                              [v2 (remove-lets (ifgreater-e2 e) )]
                              [v3 (remove-lets (ifgreater-e3 e))]
                              [v4 (remove-lets (ifgreater-e4))])
                          (ifgreater v1 v2 v3 v4)
                         )]
        [(fun? e) (let ([body (remove-lets (fun-body e))])
                    (fun (fun-nameopt e) (fun-formal e) body))]
        [(call? e) e]
        [(mlet? e) (call (fun #f (mlet-var e) (remove-lets (mlet-body e))) (mlet-e e))]
        [(apair? e) (let ([v1 (remove-lets (apair-e1 e) )]
                          [v2 (remove-lets (apair-e2 e) )])
                      (apair v1 v2))]
        [(fst? e) (let ([v (remove-lets (fst-e e))])
                    (fst v))]
        [(snd? e) (let ([v (remove-lets (snd-e e) )])
                    (snd v))]
        [(isaunit? e) ( let ( [v (remove-lets (isaunit-e e))])
                         (isaunit v))]
        [(aunit? e) e]
        [#t (error (format "bad MUPL expression: ~v" e))]))

; Q11
(define (remove-lets-and-pairs e)
  (cond [(var? e) 
         e]
        [(int? e) e]
        [(add? e) 
         (let ([v1 (remove-lets-and-pairs(add-e1 e))]
               [v2 (remove-lets-and-pairs(add-e2 e))])
           (add v1 v2))]
        [(ifgreater? e) (
                         let ([v1 (remove-lets-and-pairs (ifgreater-e1 e) )]
                              [v2 (remove-lets-and-pairs (ifgreater-e2 e) )]
                              [v3 (remove-lets-and-pairs (ifgreater-e3 e))]
                              [v4 (remove-lets-and-pairs (ifgreater-e4))])
                          (ifgreater v1 v2 v3 v4)
                         )]
        [(fun? e) (let ([body (remove-lets-and-pairs (fun-body e))])
                    (fun (fun-nameopt e) (fun-formal e) body))]
        [(call? e) e]
        [(mlet? e) (call (fun #f (mlet-var e) (remove-lets-and-pairs (mlet-body e))) (mlet-e e))]
        [(apair? e)
         (remove-lets-and-pairs (mlet "_x" (apair-e1 e) (mlet "_y" (apair-e2 e)
                                           (fun #f "_f" (call
                                                         (call (var "_f") (var "_x")) (var "_y"))))))]
        [(fst? e) (let ([v (remove-lets-and-pairs (fst-e e))])
                    (call v (fun #f  "x" (fun #f "y" (var "x")))))]
        [(snd? e) (let ([v (remove-lets-and-pairs (snd-e e) )])
                    (call v (fun #f  "x" (fun #f "y" (var "y")))))]
        [(isaunit? e) ( let ( [v (remove-lets-and-pairs (isaunit-e e))])
                         (isaunit v))]
        [(aunit? e) e]
        [#t (error (format "bad MUPL expression: ~v" e))]))

; More MUPL functions:
(define mupl-all
  (fun "mupl-all" "lst"
       (if (aunit? (var "lst"))
           (int 1)
           (ifeq (fst (var "lst")) (int 1) (call (var "mupl-all") (snd (var "lst"))) (int 0) ))))

(define mupl-append
  (fun "mupl-append" "xs"
         (fun #f "ys"
              (ifaunit (var "xs")
                       (var "ys")
                       (apair (fst (var "xs")) (call (call (var "mupl-append") (snd (var "xs")) ) (var "ys")))))))

(define mupl-zip
  (fun "mupl-zip" "xs"
       (fun #f "ys"
            (ifaunit (var "xs")
                     (aunit)
                     (ifaunit (var "ys")
                              (aunit)
                              (apair (apair (fst (var "xs")) (fst (var "ys")))
                                            (call (call (var "mupl-zip") (snd (var "xs"))) (snd (var "ys")))))))))

(define mupl-append-pair
  (fun "mupl-append" "pair"
              (ifaunit (fst (var "pair"))
                       (snd (var "pair"))
                       (apair (fst (fst (var "pair")))
                               (call (var "mupl-append")
                                     (apair (snd (fst (var "pair"))) (snd (var "pair"))))))))

(define mupl-zip-pair
  (fun "mupl-zip" "pair"
            (ifaunit (fst (var "pair"))
                     (aunit)
                     (ifaunit (snd (var "pair"))
                              (aunit)
                              (apair (apair (fst (fst (var "pair"))) (fst (snd (var "pair"))))
                                            (call (var "mupl-zip") (apair (snd (fst (var "pair"))) (snd (snd (var "pair"))))))))))

(define mupl-curry
  (fun "mupl-curry" "fn"
       (fun #f "#x"
            (fun #f "#y"
                 (call (var "fn") (apair (var "#x") (var "#y")))))))

(define mupl-uncurry
  (fun "mupl-uncurry" "fn"
       (fun #f "pair"
            (call (call (var "fn") (fst (var "pair"))) (snd (var "pair"))))))

; More MUPL macros

(define (if-greater3 e1 e2 e3 e4 e5)
                    (ifgreater e1 e2 (ifgreater e2 e3 e4 e5) e5))

(define (call-curried fn xs)
  (if (null? xs)
      fn
      (call-curried (call fn (car xs)) (cdr xs))
   ))