Welcome to the CHICKEN Scheme pasting service

xml added by phasers_to_stun on Thu Jan 14 07:00:39 2016

(use srfi-13)
(use extras)
;Returns the length of a list
(define (len lst)
  (define (len-help lst count)
    (cond ((not (eq? lst '())) (len-help (cdr lst) (+ count 1)))
          (else count)))
  (len-help lst 0))

(define (const-l fil len)
;makes a constant list of symbol fil len times
  (cond ((> len 0) (cons fil (const-l fil (- len 1))))
        (else '())))

;makes a string out of a list of tag attribute strings
(define (make-attribute-string tag-atribs)
  (cond ((eq? tag-atribs '()) "")
        (else (string-join tag-atribs " "))))

(define (indent num)
  (string-join (const-l "  " num) ""))

(define (tag-name tag)
  (car tag))

(define (tag-atribs tag)
  (cadr tag))

(define (tag-elems tag)
  (caddr tag))

(define (print-tag tag close ind)
  (cond ((eq? close #f)
          (cond ((attributes? tag) (printf "~A<~A ~A>" (indent ind) (tag-name tag) (make-attribute-string (tag-atribs tag))))
                (else (printf "~A<~A>" (indent ind) (tag-name tag)))))
        ((eq? close #t) (printf "~A<~A/>" (indent ind)(tag-name tag)))))

(define (children? tag)
  (not (eq? (tag-elems tag) '())))

(define (attributes? tag)
  (not (eq? (tag-atribs tag) '())))

(define (display-xml tag)
  (define (recursive-display tag ind)
    (cond ((list? tag)
            (print-tag tag #f ind)
            (cond
              ((children? tag)
                (newline)
                (map (lambda (tg)
                       (recursive-display tg (+ ind 1)))
                     (tag-elems tag))
                (newline)
                (print-tag tag #t ind))
              (else (print-tag tag #t 0) (newline))))
          (else (printf "~A~A" (indent ind) tag))))
  (recursive-display tag 0))


(define tag1
  (list 'html '()
    (list
      (list 'body '()
        (list
          (list 'h1 '() '(name))
          (list 'p '() '(place)))))))

(define tag2
  (list 'html '()
    (list
      (list 'body '()
        (list
          (list 'h1 '() '())
          (list 'p '() '()))))))

(define tag3
  '(html ()
     (
       (body ()
         (
           (h1 () (name))
           (p () (place))
         ))
     )))
(write "with list notation, notice the <p> tag is on the wrong line")
(newline)
(display-xml tag1)
(newline)(newline)
(write "with list notation and the text removed the <p> tag is on the correct line")
(newline)
(display-xml tag2)
(newline)(newline)
(write "using a quote for more succinct notation as a test")
(newline)
(display-xml tag3)

Your annotation:

Enter a new annotation:

Your nick:
The title of your paste:
Your paste (mandatory) :
Which egg provides `take-right'?
Visually impaired? Let me spell it for you (wav file) download WAV