;;; (SEXP->XML SEXP) provides the translation of xml of a ;;; Scheme S-expression ;; --------------------------------------------------------------------- (define (sexp->xml sexp) (cond ((number? sexp) `( ,sexp )) ((symbol? sexp) `( ,sexp )) ((null? sexp) `( ,sexp )) ((boolean? sexp) `( ,(if sexp 'true 'false) )) ((string? sexp) `( ,sexp )) ((lambda? sexp) (sexp-lambda->xml (cadr sexp) (cddr sexp))) ((define-var? sexp) (sexp-define->xml (cadr sexp) (caddr sexp))) ((define-fn? sexp) (sexp-define->xml (caadr sexp) `(lambda ,(cdadr sexp) ,@(cddr sexp)))) ((let? sexp) (sexp-let->xml-proc (cadr sexp) (cddr sexp))) ((let*? sexp) (sexp-let*->xml (cadr sexp) (cddr sexp))) ((begin? sexp) (sexp-begin->xml (cdr sexp))) ((if? sexp) (sexp-if->xml (cadr sexp) (cddr sexp))) ((cond? sexp) (sexp-cond->xml (cdr sexp))) ((quote? sexp) (sexp-quote->xml (cadr sexp))) ((applic? sexp) (sexp-applic->xml sexp)))) ;;; Various discriminant functions for S-expressions ;; --------------------------------------------------------------------- (define (lambda? xs) (eq? (car xs) 'lambda)) (define (applic? xs) (list? xs)) (define (define-var? xs) (and (eq? (car xs) 'define) (symbol? (cadr xs)))) (define (define-fn? xs) (and (eq? (car xs) 'define) (list? (cadr xs)))) (define (let? xs) (eq? (car xs) 'let)) (define (let*? xs) (eq? (car xs) 'let*)) (define (quote? xs) (eq? (car xs) 'quote)) (define (if? xs) (eq? (car xs) 'if)) (define (cond? xs) (eq? (car xs) 'cond)) (define (begin? xs) (eq? (car xs) 'begin)) ;;; Various helper functions for SEXP->XML ;;; Each one processes one kind of expressions ;; --------------------------------------------------------------------- (define (sexp-lambda->xml bvars body) `( ,@bvars ,@(append-map sexp->xml body) )) (define (sexp-define->xml bvar val) `( ,bvar ,@(sexp->xml val) )) (define (sexp-let->xml bindings body) (define (sexp-binding->xml binding) `( ,(car binding) ,@(sexp->xml (cadr binding)) )) `( ,@(append-map sexp-binding->xml bindings) ,@(sexp->xml body) )) (define (sexp-begin->xml sexp) `( ,@(append-map sexp->xml sexp) )) (define (sexp-if->xml test consequent-alternate) (if (null? (cdr consequent-alternate)) `( ,@(sexp->xml test) ,@(sexp->xml (car consequent-alternate)) ) `( ,@(sexp->xml test) ,@(sexp->xml (car consequent-alternate)) ,@(sexp->xml (cadr consequent-alternate)) ))) (define (sexp-cond->xml clauses) (cond ((null? clauses) '()) ((eq? (caar clauses) 'else) (sexp->xml (cadar clauses))) (else `( ,@(sexp->xml (caar clauses)) ,@(sexp->xml (cadar clauses)) ,@(sexp-cond->xml (cdr clauses)) )))) ;;; Note how quote are handled ;; --------------------------------------------------------------------- (define (sexp-quote->xml sexp) (define (sexp-quote->xml sexp) (cond ((number? sexp) `( ,sexp )) ((symbol? sexp) `( ,sexp )) ((null? sexp) `( ,sexp )) ((boolean? sexp) `( ,(if sexp 'true 'false) )) ((string? sexp) `( ,sexp )) ((pair? sexp) `( ,@(sexp-quote->xml (car sexp)) ,@(sexp-quote->xml (cdr sexp)) )))) `( ,@(sexp-quote->xml sexp) )) (define (sexp-applic->xml sexp) `( ,@(append-map sexp->xml sexp) )) ;;; Functions on Tags ;; --------------------------------------------------------------------- (define (otag? sym) (if (symbol? sym) (let ((str (symbol->string sym))) (and (eq? (string-ref str 0) #\<) (not (eq? (string-ref str 1) #\/)) (eq? (string-ref str (- (string-length str) 1)) #\>))) #f)) (define (ctag? sym) (if (symbol? sym) (let ((str (symbol->string sym))) (and (eq? (string-ref str 0) #\<) (eq? (string-ref str 1) #\/) (eq? (string-ref str (- (string-length str) 1)) #\>))) #f)) (define (ctag sym) (let ((name (string->list (symbol->string sym)))) (string->symbol (list->string (cons (car name) (cons #\/ (cdr name))))))) (define (otag->name sym) (let ((str (symbol->string sym))) (string->symbol (substring str 1 (- (string-length str) 1))))) ;;; ONELINER? ;;; indicates whether the tag can be printed in one line or not ;; --------------------------------------------------------------------- (define oneliner '( )) (define (oneliner? x) (if (memq x oneliner) #t #f)) ;;; Pretty printer ;;; it will print on one line only short elements, ;;; those whose tag answer true to oneliner? ;; --------------------------------------------------------------------- (define (xml-pp xml) (define (indent n elem oneliner?) (cond (oneliner? (display " ")) (else (newline) (do ((i 0 (+ i 1))) ((= i n)) (display " ")))) (display elem)) (define (pp xml n oneliners) (cond ((null? xml) (newline) (values)) ((null? (car xml)) (indent n (car xml) (car oneliners)) (pp (cdr xml) n oneliners)) ((otag? (car xml)) (indent n (car xml) (car oneliners)) (pp (cdr xml) (+ n 1) (cons (oneliner? (car xml)) oneliners))) ((ctag? (car xml)) (indent (- n 1) (car xml) (car oneliners)) (pp (cdr xml) (- n 1) (cdr oneliners))) (else (indent n (car xml) (car oneliners)) (pp (cdr xml) n oneliners)))) (pp xml 0 '(#f))) ;; (XML->SEXP XML) translates XML elements to S-expressions ;; --------------------------------------------------------------------- (define (xml->sexp xml) ;;; write your definition for XML->SEXP here ;;; You may want to consider returning multiple values ) ;;; SICP p.115 (define (filter predicate? sequence) (cond ((null? sequence) '()) ((predicate? (car sequence)) (cons (car sequence) (filter predicate? (cdr sequence)))) (else (filter predicate? (cdr sequence))))) ;;; SICP p.116 (accumulate) (define (foldr op initial sequence) (if (null? sequence) initial (op (car sequence) (foldr op initial (cdr sequence))))) ;;; SICP p.121 (fold-left) (define (foldl op initial sequence) (define (iter result rest) (if (null? rest) result (iter (op result (car rest)) (cdr rest)))) (iter initial sequence)) (define (1+ n) (+ n 1)) (define (-1+ n) (- n 1)) (define (append-map f l) (apply append (map f l))) ; http://www.cs.toronto.edu/~carneiro/324/tutorial/tutorial4.txt ;The students have now seen 'map', 'apply', and 'reduce' in class. ;The first two are built-in HOPs; the third is one we define in class. ;Here is the code for your reference: ; (reduce op lst id) applies the binary operator op to the elements of ; list right-associatively, or returns id (the identity element) if lst ; is empty. ; Pre: op is a binary procedure, lst is a list of valid arguments to op, ; and id is the identity value for op, i.e., (op x id) => x for all x that ; are valid arguments to op. (define reduce (lambda (op lst id) (cond ((null? lst) id) (else (op (car lst) (reduce op (cdr lst) id)))))) ;The beauty of reduce is that it can convert a binary function ;into an n-ary function. ; ;E.g., "union" takes 2 lists and returns their union, so when we have ;a list of 2 lists, we can use apply, ; (apply union '((1 3) (2 3 4)) ; => (1 2 3 4) ; ;BUT ; (apply union '((1 3) (2 3) (4 5))) ; produces an error ; ;INSTEAD ; (reduce union '((1 3) (2 3) (4 5)) ()) ; => (1 2 3 4 5) ; ;(Trace reduce, if you're still unclear. ; ;You can also try to define with the students a similar procedure reduce, ;where the operator is applied left-associatively or return id if the ;list is empty. (define reduce-left (lambda (op lst id) (cond ((null? lst) id) (else (op (reduce-left op (cdr lst) id) (car lst) ))))) ;(reduce-left / '(24 6 2) 1) => 1/288