#lang racket

;;;****************************************************************************
;;; Desugaring framework

(define show-one-step-desugarings? #f) ; controls tracing within desugar

;; desugar peforms a complete desugaring, apply desugar-rewrite-one-step
;; as many times as necessary and on as many parts as necessary. 
(define (desugar sexp)
  (let {[dsexp (desugar-rewrite-one-step sexp)]} ; dsexp is the desugared sexp
    (if (not (equal? dsexp sexp))
        ;; then case: a desugaring rewrite rule transformed the top-level sexp 
        ;; to dsexp; iteratively apply desugaring rewrite rules to dsexp
        (begin (if show-one-step-desugarings?
                   ;; show details of one-step rewriting in this case
                   (begin (printf "desugar-rewrite-one-step:\n")
                          (pretty-display sexp)
                          (printf "=> ")
                          (pretty-display dsexp)
                          (printf "\n"))
                   'do-nothing)   
               (desugar dsexp))
        ;; else case: desugaring rules didn't change the top-level sexp,
        ;; so it must be a kernel sexp; now apply desugaring rules to
        ;; subtrees of the kernel sexp
        (cond ((literal? sexp) sexp)
              ((identifier? sexp) sexp)
              ((definition? sexp)
               (make-definition (definition-name-part sexp)
                                (desugar (definition-defn sexp))))
              ((if? sexp)
               (make-if (desugar (if-test sexp))
                        (desugar (if-then sexp))
                        (desugar (if-else sexp))))
              ((lambda? sexp)
               (make-lambda (lambda-params sexp)
                            (desugar (lambda-body sexp))))
              ((call? sexp)
               (make-call (desugar (call-rator sexp))
                          (map desugar (call-rands sexp))))
              ((letrec? sexp)
               (make-letrec (letrec-names sexp)
                            (map desugar (letrec-defns sexp))
                            (desugar (letrec-body sexp))))
              (else (error "Unhandled expression" sexp))
              ))))

;;;****************************************************************************
;;; One-step desugaring rewrite rules

;;----------------------------------------
;; desugar-rewrite-one-step dispatches to a 
;; specialized function for each sugar construct. 
;;
(define (desugar-rewrite-one-step sexp)
  (cond ((definition? sexp) (desugar-definition sexp))
        ((let? sexp) (desugar-let sexp))
        ((let*? sexp) (desugar-let* sexp))
        ((cond? sexp) (desugar-cond sexp))
        ((begin? sexp) (desugar-begin sexp))
        ((and? sexp) (desugar-and sexp))
        ((or? sexp) (desugar-or sexp))
        (else sexp) ; otherwise return expression unchanged
        ))

;;----------------------------------------
;; desugar-definition implements this one desugaring rule:
;;
;; (define (Id_fun Id_param_1 ... Id_param_n) E_body)
;; => (define Id_fun (lambda (Id_param_1 ... Id_param_n) E_body))
;;
(define (desugar-definition sexp)
  (let {[name-part (definition-name-part sexp)]
        [defn (definition-defn sexp)]}
    (if (list? name-part) ; has form (Id_fun Id_param_1 ... Id_param_n)
        ;; (define (Id_fun Id_param_1 ... Id_param_n) Ebody)
        ;;   => (define Id_fun (lambda (Id_param_1 ... Id_param_n) Ebody)
        (make-definition (first name-part)
                         (make-lambda (rest name-part) defn))
        ;; otherwise has form (define Id_name E_defn); return this unchanged.
        sexp)))

;;----------------------------------------
;; desugar-let implements this one desugaring rule:
;;
;; (let {[Id1 E1] ... [In En]} Ebody)
;;   => ((lambda (Id1 ... Idn) Ebody) E1 ... En)
;; 
(define (desugar-let sexp)
  (make-call (make-lambda (let-names sexp)
                          (let-body sexp))
             (let-defns sexp)))

;; desugar-or should implement these three desugaring rules
;;
;; 1. (or) => #f
;;
;; 2. (or E) => E
;; 
;; 3. (or E ...) => (let {[Id_fresh E]}
;;                    (if Id_fresh Id_fresh (or ...)))
;;    ;; Note: use (fresh-identifier) to generate Id_fresh
;;
(define (desugar-or sexp)
  (let {[disjuncts (or-disjuncts sexp)]}
    (cond ((null? disjuncts)
           ;; (or) => #f
           #f)
          ((= (length disjuncts) 1)
           ;; (or E) => E
           (first disjuncts))
          (else
           ;; (or E ...) => (let {[Id_fresh E]}
           ;;                 (if Id_fresh Id_fresh (or ...))) 
           (let {[fresh (fresh-identifier)]} ;; name fresh identifier so that
                                             ;; same identifier is use multiple times
             (make-let (list fresh) ; list of one identifier
                       (list (first disjuncts)) ; list of one defn exp
                       (make-if fresh
                                fresh
                                (make-or (rest disjuncts))))))
          )))

;;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
;; FOR PS6 PROBLEM 2, WRITE YOUR SOLUTIONS BELOW:
;;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

;; desugar-and should implement these three desugaring rules
;;
;; 1. (and) => #t
;;
;; 2. (and E) => E
;; 
;; 3. (and E ...) => (if E (and ...) #f) 
;;
(define (desugar-and sexp)
  'flesh-out-desugar-and)

;; desugar-let* should implement these two desugaring rules
;;
;; 1. (let* { } Ebody) => Ebody
;;
;; 2. (let* {[Id1 E1] ...} Ebody)
;;    => (let {[Id1 E1]}
;;         (let* {...} Ebody))
;; 
(define (desugar-let* sexp)
  'flesh-out-desugar-let*)

;; desugar-cond should implement these two desugaring rules
;;
;; 1. (cond (else E)) => E
;;
;; 2. (cond (Etest Ebody) ...) => (if Etest Ebody (cond ...))
;; 
(define (desugar-cond sexp)
  'flesh-out-desugar-cond)

;; desugar-begin* should implement these two desugaring rules
;;
;; 1. (begin E) => E
;;
;; 2. (begin E1 ...) => (let {[Id_fresh E1]} (begin ...)
;;    ;; Note: use (fresh-identifier) to generate Id_fresh
;;
(define (desugar-begin sexp)
  'flesh-out-desugar-begin)

;;;****************************************************************************
;;; Syntactic abstractions

;;----------------------------------------
;; identifiers (variable names) are just symbols
(define (identifier? sexp) (symbol? sexp))

;;----------------------------------------
;; literal expressions (i.e, numbers, booleans, strings, all quoted expressions)
(define (literal? sexp)
  (or (number? sexp)
      (boolean? sexp)
      (string? sexp)
      (quoted? sexp)))

;;----------------------------------------
;; quoted expressions have the form (quote <sexp>)
;; where <sexp> is any single s-expression
(define (quoted? sexp)
  (and (list? sexp)
       (= (length sexp) 2)
       (eq? (first sexp) 'quote)))

;;----------------------------------------
;; if expressions have the form
;;   (if E_test E_then E_else)

(define (make-if test thn els) (list 'if test thn els))
(define (if-test sexp) (second sexp))
(define (if-then sexp) (third sexp))
(define (if-else sexp) (fourth sexp))

(define (if? sexp)
  (and (list? sexp)
       (= (length sexp) 4)
       (eq? (first sexp) 'if)))

;;----------------------------------------
;; lambda expressions have the form
;;   (lambda (Id_param_1 ... Id_param_n) E_body)
;; where n >= 0

(define (make-lambda params body)
  (if (forall? symbol? params)
      (list 'lambda params body)
      (error "make-lambda: params aren't all symbols" params)))
(define (lambda-params sexp) (second sexp))
(define (lambda-body sexp) (third sexp))

(define (lambda? sexp)
  (and (list? sexp)
       (= (length sexp) 3)
       (eq? (first sexp) 'lambda)
       (list? (second sexp))
       (forall? symbol? (second sexp))))

;;----------------------------------------
;; function calls have the form
;;   (E_rator E_rand_1 ... E_rand_n)
;; where n >= 0

(define (make-call rator rands)
  (if (memq rator '(and begin cond define if lambda
                    let let* letrec or quote))
      (error "make-call: function calls can't begin with core or sugar keyword"
             rator)
      (cons rator rands)))
  
(define (call-rator sexp) (first sexp))
(define (call-rands sexp) (rest sexp))

(define (call? sexp)
  (and (list? sexp)
       (>= (length sexp) 1)
       ;; Function calls can't begin with core or sugar keyword
       (not (memq (first sexp) '(and begin cond define if lambda
                                 let let* letrec or quote)))
       ))

;;----------------------------------------
;; let expressions have the form  
;;   (let {[Id_name_1 Id_defn_1]
;;         ...
;;         [Id_name_n Id_defn_n]}
;;     E_body)
;; where n >= 0

(define (make-let names defns body)
  (if (and (forall? symbol? names)
           (= (length names) (length defns)))
      (list 'let
            (map (lambda (name defn) (list name defn)) names defns)
            body)
      (error "make-let: malformed let parts"
             (list 'let names defns body))))

(define (let-bindings sexp) (second sexp))
(define (let-names sexp) (map first (let-bindings sexp)))
(define (let-defns sexp) (map second (let-bindings sexp)))
(define (let-body sexp) (third sexp))
  
(define (let? sexp)
  (and (list? sexp)
       (= (length sexp) 3)
       (eq? (first sexp) 'let)
       (list (second sexp)) ; must be a list of bindings
       (forall? binding? (second sexp))))

(define (binding? sexp) ; name/defn binding, e.g. '(sqr (* a a))
  (and (list? sexp)
       (= (length sexp) 2)
       (symbol? (first sexp))))

;;----------------------------------------
;; let* expressions have the form  
;;   (let* {[Id_name_1 Id_defn_1]
;;          ...
;;          [Id_name_n Id_defn_n]}
;;     E_body)
;; where n >= 0

(define (make-let* names defns body)
  (if (and (forall? symbol? names)
           (= (length names) (length defns)))
      (list 'let*
            (map (lambda (name defn) (list name defn)) names defns)
            body)
      (error "make-let*: malformed let* parts"
             (list 'let* names defns body))))

(define (let*-bindings sexp) (second sexp))
(define (let*-names sexp) (map first (let*-bindings sexp)))
(define (let*-defns sexp) (map second (let*-bindings sexp)))
(define (let*-body sexp) (third sexp))

(define (let*? sexp)
  (and (list? sexp)
       (= (length sexp) 3)
       (eq? (first sexp) 'let*)
       (list (second sexp)) ; must be a list of bindings
       (forall? binding? (second sexp))))

;;----------------------------------------
;; letrec expressions have the form  
;;   (letrec {[Id_name_1 Id_defn_1]
;;            ...
;;            [Id_name_n Id_defn_n]}
;;     E_body)
;; where n >= 0

(define (make-letrec names defns body)
  (if (and (forall? symbol? names)
           (= (length names) (length defns)))
      (list 'letrec
            (map (lambda (name defn) (list name defn)) names defns)
            body)
      (error "make-letrec: malformed letrec parts"
             (list 'letrec names defns body))))

(define (letrec-bindings sexp) (second sexp))
(define (letrec-names sexp) (map first (letrec-bindings sexp)))
(define (letrec-defns sexp) (map second (letrec-bindings sexp)))
(define (letrec-body sexp) (third sexp))

(define (letrec? sexp)
  (and (list? sexp)
       (= (length sexp) 3)
       (eq? (first sexp) 'letrec)
       (list (second sexp)) ; must be a list of bindings
       (forall? binding? (second sexp))))

;;----------------------------------------
;; begin expressions have the form
;;   (begin E_sequent_1 ... E_sequent_n),
;; where n >= 1

(define (make-begin sequents)
  (if (= (length sequents) 0)
      (error "make-begin: begin must have at least one sequent")
      (cons 'begin sequents)))
  
(define (begin-sequents sexp) (rest sexp))
 
(define (begin? sexp)
  (and (list? sexp)
       (>= (length sexp) 2) ; Must contain at least one sequent
       (eq? (first sexp) 'begin)))

;;----------------------------------------
;; cond expressions have the form
;;   (cond (E_test_1 E_body_1)
;;         ...
;;         (E_test_n E_body_n)) 
;; where n >= 1 and E_test_n must be `else`

(define (make-cond clauses)
  (if (and (>= (length clauses) 1)
           (forall? cond-clause? clauses)
           (eq? (first (last clauses)) 'else))       
      (cons 'cond clauses)
      (error "make-cond: malformed cond clauses" clauses)))

(define (cond-clauses sexp) (rest sexp))

(define (cond? sexp)
  (and (list? sexp)
       (>= (length sexp) 2) ; must have a least one clause
       (eq? (first sexp) 'cond)
       (forall? cond-clause? (rest sexp))
       (eq? (first (last sexp)) 'else) ; last clause must begin with else
       ))

(define (make-cond-clause test body) (list test body))
(define (cond-clause-test sexp) (first sexp))
(define (cond-clause-body sexp) (second sexp))
 
(define (cond-clause? sexp)
  (and (list? sexp)
       (= (length sexp) 2) ; has form (Etest Ebody)
       ))

;;----------------------------------------
;; and expressions have the form
;;  (and E_conjunct_1 ... E_conjunct_n)
;; where n >= 0

(define (make-and conjuncts) (cons 'and conjuncts))
(define (and-conjuncts sexp) (rest sexp))
(define (and? sexp)
  (and (list? sexp)
       (>= (length sexp) 1)
       (eq? (first sexp) 'and)))

;;----------------------------------------
;; or expressions have the form
;;   (or E_disjunct_1 ... E_disjunct_n) 
;; where n >= 0

(define (make-or disjuncts) (cons 'or disjuncts))
(define (or-disjuncts sexp) (rest sexp))
(define (or? sexp)
  (and (list? sexp)
       (>= (length sexp) 1)
       (eq? (first sexp) 'or)))

;;----------------------------------------
;; definitions
;; These have one of two forms:
;; 1. (define Id_name E_defn)
;; 2. (define (Id_fun Id_param_1 ... Id_param_n) E_defn), where n >= 0

(define (make-definition name-part defn)
  ;; name part can be Id or (Id_fun Id_param_1 ... Id_param_n)
  (if (or (symbol? name-part) ; Id_name
          (forall? symbol? name-part)) ; (Id_fun Id_param_1 ... Id_param_n)
      (list 'define name-part defn)
      (error "make-definition: malformed name-part" name-part)))

(define (definition-name-part sexp) (second sexp))
(define (definition-defn sexp) (third sexp))

(define (definition? sexp)
  (and (list? sexp)
       (= (length sexp) 3)
       (eq? (first sexp) 'define)
       (or (symbol? (second sexp)) ; Id_name
           (forall? symbol? (second sexp))) ; (Id_fun Id_param_1 ... Id_param_n)
       ))

;;----------------------------------------
;; Simple way to generate fresh identifiers
;; Calling (fresh-identifier) returns an identifier of the form
;; id.<num>, where <num> is different every time it's called.
;; This is sensible as long as you don't use identifiers of this form
;; in your code. 
;; (This function uses side effects, which we haven't seen before this
;;  semester, but we'll study them in the last class if there is time.)
(define *fresh-id-counter* 0)

;; reset identifier counter to 0
;; (needed for ensure consistent counters for testing)
(define (reset-fresh-identifier!)
  (set! *fresh-id-counter* 0)) 

(define (fresh-identifier)
  (begin (set! *fresh-id-counter*
               (+ *fresh-id-counter* 1))
         (string->symbol
          (string-append "id."
                         (number->string *fresh-id-counter*)))))

;;;****************************************************************************
;;; Helper function

(define (forall? pred xs)
  (if (null? xs)
      #t
      (and (pred (first xs))
           (forall? pred (rest xs)))))

;;;****************************************************************************
;;; Testing

(define (make-tester name fcn case-list)
  (define (test cases passes fails)
    (if (null? cases)
        (begin (if (= passes (length case-list))
                   (printf "\nSummary for ~a: passed all ~a tests\n" name passes)
                   (printf "\nSummary for ~a: passed ~a tests and failed ~a tests\n"
                           name passes fails))
               (list passes fails))
        (let* {[case (first cases)]
               [input (first case)]
               [expected (second case)]
               [ignore (reset-fresh-identifier!)]
               [actual (fcn input)]}
          (if (equal? actual expected)
              (test (rest cases) (+ passes 1) fails)
              (begin (printf "\n*** Testing error for ~a\n" name)
                     (printf "   Input: ~a\n" input)
                     (printf "Expected: ~a\n" expected)
                     (printf "  Actual: ~a\n" actual)
                     (test (rest cases) passes (+ fails 1)))))))
  (lambda () ; return a nullary testing function
    (begin (printf "\n--------- testing ~a ----------" name)
           (test case-list 0 0))))


 
;;----------------------------------------
;; testing for desugar-and

(define desugar-and-test-cases
  ;; a list of input/expected-output pairs
  '(
    ( (and)
      #t )

    ( (and (< a b))
      (< a b) )

    ( (and (< a b) (< b c) (< c d))
      (if (< a b) (and (< b c) (< c d)) #f) )
    ))

(define test-desugar-and
  (make-tester 'desugar-and
               desugar-and
               desugar-and-test-cases))

;;----------------------------------------
;; testing for desugar-let*

(define desugar-let*-test-cases
  ;; a list of input/expected-output pairs
  '(
    ( (let* {} (list a b))
      (list a b) )

    ( (let* {[b (* a a)]} (list a b))
      (let ((b (* a a))) (let* () (list a b))) )

    ( (let* {[a (+ x 1)] [b (* a a)]} (list a b))
      (let ((a (+ x 1))) (let* ((b (* a a))) (list a b))) )
    ))

(define test-desugar-let*
  (make-tester 'desugar-let*
               desugar-let*
               desugar-let*-test-cases))

;;----------------------------------------
;; testing for desugar-cond

(define desugar-cond-test-cases
  ;; a list of input/expected-output pairs
  '(
    ((cond (else (- a b)))
     (- a b))

    ((cond ((= a b) (* a b)) (else (- a b)))
     (if (= a b) (* a b) (cond (else (- a b)))))

    ((cond ((< a b) (+ a b)) ((= a b) (* a b)) (else (- a b)))
     (if (< a b) (+ a b) (cond ((= a b) (* a b)) (else (- a b)))))
    ))

(define test-desugar-cond
  (make-tester 'desugar-cond
               desugar-cond
               desugar-cond-test-cases))

;;----------------------------------------
;; testing for desugar-begin

(define desugar-begin-test-cases
  ;; a list of input/expected-output pairs
  '(
    
    ( (begin (+ x y))
      (+ x y) )

    ( (begin (printf "y is ~a\n" y)
             (+ x y))
      (let ((id.1 (printf "y is ~a\n" y)))
        (begin (+ x y)) ))

    ( (begin (printf "x is ~a\n" x)
             (printf "y is ~a\n" y)
             (+ x y))
      (let ((id.1 (printf "x is ~a\n" x)))
        (begin (printf "y is ~a\n" y) (+ x y))))
    ))

(define test-desugar-begin
  (make-tester 'desugar-begin
               desugar-begin
               desugar-begin-test-cases))
;;----------------------------------------
;; testing for desugar 

;; Large test cases
(define big-sexp
  '(define (test-repl prompt done)
     (begin (printf "~a x>" prompt)
            (let {[x (read)]}
              (if (equal? x done)
                  'repl-done
                  (begin (printf "~a y>" prompt)
                         (let* {[y (read)]
                                [result
                                 (cond ((or (< x y)
                                            (> y 100) 
                                            (and (< 10 x)
                                                 (< y (* 2 x))
                                                 (< y 50)))
                                        (let* {[a (+ x y)]
                                               [b (* x a)]
                                               [c (/ a b)]}
                                          (list x y a b c)))
                                       ((and (> x y) (> (* 3 x) y))
                                        (list x y (* y y)))
                                       (else (list x y)))]}
                           (begin (printf "Result is ~a\n" result)
                                  (test-repl prompt done)))))))))

(define big-sexp-desugaring
  '(define test-repl
     (lambda (prompt done)
       ((lambda (id.1)
          ((lambda (x)
             (if (equal? x done)
                 'repl-done
                 ((lambda (id.2)
                    ((lambda (y)
                       ((lambda (result) ((lambda (id.3) (test-repl prompt done)) (printf "Result is ~a\n" result)))
                        (if ((lambda (id.4) (if id.4 id.4 ((lambda (id.5) (if id.5 id.5 (if (< 10 x) (if (< y (* 2 x)) (< y 50) #f) #f))) (> y 100))))
                             (< x y))
                            ((lambda (a) ((lambda (b) ((lambda (c) (list x y a b c)) (/ a b))) (* x a))) (+ x y))
                            (if (if (> x y) (> (* 3 x) y) #f) (list x y (* y y)) (list x y)))))
                     (read)))
                  (printf "~a y>" prompt))))
           (read)))
        (printf "~a x>" prompt)))))

(define desugar-test-cases
  ;; a list of input/expected-output pairs
  (list
   '((and (< a b) (< b c) (< c d))
     (if (< a b) (if (< b c) (< c d) #f) #f))

   '((let* {[a (+ x 1)] [b (* a a)]} (list a b))
     ((lambda (a) ((lambda (b) (list a b)) (* a a))) (+ x 1)))

   '((cond ((< a b) (+ a b)) ((= a b) (* a b)) (else (- a b)))
     (if (< a b) (+ a b) (if (= a b) (* a b) (- a b))))

   '((begin (printf "x is ~a\n" x) (printf "y is ~a\n" y) (+ x y))
     ((lambda (id.1) ((lambda (id.2) (+ x y))
                      (printf "y is ~a\n" y)))
      (printf "x is ~a\n" x)))

   (list big-sexp big-sexp-desugaring)))

(define test-desugar
  (make-tester 'desugar
               desugar
               desugar-test-cases))

;;----------------------------------------
;; test all testers

(define (combine-testers testers)
  (lambda ()
    (let* {[passes/fails (map (lambda (tester) (tester)) testers)]
           [passes (foldl + 0 (map first passes/fails))]
           [fails (foldl + 0 (map second passes/fails))]
           [total (+ passes fails)]}
      (begin (printf "\n---Summary for all testers---:\n")
             (if (= passes total)
                 (printf "Passed all ~a test cases" passes)
                 (printf "Passed ~a and failed ~a test cases" passes fails))))))

(define test-all
  (combine-testers
   (list test-desugar-and
         test-desugar-let*
         test-desugar-cond
         test-desugar-begin
         test-desugar)))