;; Demo of map/reduce and let

(define-struct line (x1 y1 x2 y2))

(define (dv n) (display (exact->inexact n)))

(define (disp-line x1 y1 x2 y2) (display "<line x1=\"") (dv x1) (display "\" y1=\"") (dv y1) (display "\" x2=\"") (dv x2) (display "\" y2=\"") (dv y2) (display "\" />\n"))

(define (mod-line L) (let ((len (/ (+ (abs (- (line-x1 L) (line-x2 L))) (abs (- (line-y1 L) (line-y2 L)))) 4)) (dir (cond 
	((< (line-x1 L) (line-x2 L)) 1)
	((< (line-y1 L) (line-y2 L)) 2)
	((> (line-x1 L) (line-x2 L)) 3)
	((> (line-y1 L) (line-y2 L)) 4))))
	(let ((l2 (* len 2)))
	(cond 
		((= dir 1) (list (line (line-x1 L) (line-y1 L) (+ (line-x1 L) len) (line-y1 L))
					  (line (+ (line-x1 L) len) (line-y1 L) (+ (line-x1 L) len) (+ (line-y1 L) len))
					  (line (+ (line-x1 L) len) (+ (line-y1 L) len) (+ (line-x1 L) l2) (+ (line-y1 L) len))
					  (line (+ (line-x1 L) l2) (+ (line-y1 L) len) (+ (line-x1 L) l2) (- (line-y1 L) len))
					  (line (+ (line-x1 L) l2) (- (line-y1 L) len) (- (line-x2 L) len) (- (line-y2 L) len))
					  (line (- (line-x2 L) len) (- (line-y2 L) len) (- (line-x2 L) len) (line-y2 L))
					  (line (- (line-x2 L) len) (line-y2 L) (line-x2 L) (line-y2 L))))
		((= dir 2) (list (line (line-x1 L) (line-y1 L) (line-x1 L) (+ (line-y1 L) len))
					  (line (line-x1 L) (+ (line-y1 L) len) (- (line-x1 L) len) (+ (line-y1 L) len))
					  (line (- (line-x1 L) len) (+ (line-y1 L) len) (- (line-x1 L) len) (+ (line-y1 L) l2))
					  (line (- (line-x1 L) len) (+ (line-y1 L) l2) (+ (line-x1 L) len) (+ (line-y1 L) l2))
					  (line (+ (line-x1 L) len) (+ (line-y1 L) l2) (+ (line-x2 L) len) (- (line-y2 L) len))
					  (line (+ (line-x2 L) len) (- (line-y2 L) len) (line-x2 L) (- (line-y2 L) len))
					  (line (line-x2 L) (- (line-y2 L) len) (line-x2 L) (line-y2 L))))
		((= dir 3) (list (line (line-x1 L) (line-y1 L) (- (line-x1 L) len) (line-y1 L))
					  (line (- (line-x1 L) len) (line-y1 L) (- (line-x1 L) len) (- (line-y1 L) len))
					  (line (- (line-x1 L) len) (- (line-y1 L) len) (- (line-x1 L) l2) (- (line-y1 L) len))
					  (line (- (line-x1 L) l2) (- (line-y1 L) len) (- (line-x1 L) l2) (+ (line-y1 L) len))
					  (line (- (line-x1 L) l2) (+ (line-y1 L) len) (+ (line-x2 L) len) (+ (line-y2 L) len))
					  (line (+ (line-x2 L) len) (+ (line-y2 L) len) (+ (line-x2 L) len) (line-y2 L))
					  (line (+ (line-x2 L) len) (line-y2 L) (line-x2 L) (line-y2 L))))
		((= dir 4) (list (line (line-x1 L) (line-y1 L) (line-x1 L) (- (line-y1 L) len))
					  (line (line-x1 L) (- (line-y1 L) len) (+ (line-x1 L) len) (- (line-y1 L) len))
					  (line (+ (line-x1 L) len) (- (line-y1 L) len) (+ (line-x1 L) len) (- (line-y1 L) l2))
					  (line (+ (line-x1 L) len) (- (line-y1 L) l2) (- (line-x1 L) len) (- (line-y1 L) l2))
					  (line (- (line-x1 L) len) (- (line-y1 L) l2) (- (line-x2 L) len) (+ (line-y2 L) len))
					  (line (- (line-x2 L) len) (+ (line-y2 L) len) (line-x2 L) (+ (line-y2 L) len))
					  (line (line-x2 L) (+ (line-y2 L) len) (line-x2 L) (line-y2 L))))))))

(define (disp-line-list L) (disp-line (line-x1 L) (line-y1 L) (line-x2 L) (line-y2 L)))

(define (make-big-list LI R) (cond ((> R 0) (make-big-list (foldl append '() (map mod-line LI)) (- R 1)))
											  (else LI)))

(define (write-lines L R) (map disp-line-list (make-big-list (list L) R)))

(define (test-cases) (map disp-line-list (foldl append '() (list 
	(mod-line (line 300 400 100 400))
	(mod-line (line 400 500 400 700))
	(mod-line (line 500 400 700 400))
	(mod-line (line 400 300 400 100))))))

;;(define (write-all) (display "<svg width=\"800\" height=\"800\" xmlns='http://www.w3.org/2000/svg' xmlns:xlink='http://www.w3.org/1999/xlink'>
;;									  <g stroke=\"black\" stroke-width=\"1\" stroke-linecap=\"round\">\n") (test-cases)  (display "</g>\n</svg>\n"))

(define (write-all) (display "<svg width=\"800\" height=\"800\" xmlns='http://www.w3.org/2000/svg' xmlns:xlink='http://www.w3.org/1999/xlink'>
									  <g stroke=\"black\" stroke-width=\"1\" stroke-linecap=\"round\">\n") (write-lines (line 0 400 800 400) 6)  (display "</g>\n</svg>\n"))

(with-output-to-file "worm.svg" write-all)