; five weekends
(define (range . args)
(case (length args)
((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
((3) (let ((le? (if (negative? (caddr args)) >= <=)))
(let loop ((x(car args)) (xs '()))
(if (le? (cadr args) x)
(reverse xs)
(loop (+ x (caddr args)) (cons x xs))))))
(else (error 'range "unrecognized arguments"))))
(define-syntax fold-of
(syntax-rules (range in is)
((_ "z" f b e) (set! b (f b e)))
((_ "z" f b e (v range fst pst stp) c ...)
(let* ((x fst) (p pst) (s stp)
(le? (if (positive? s) =)))
(do ((v x (+ v s))) ((le? p v) b)
(fold-of "z" f b e c ...))))
((_ "z" f b e (v range fst pst) c ...)
(let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
(fold-of "z" f b e (v range x p s) c ...)))
((_ "z" f b e (v range pst) c ...)
(fold-of "z" f b e (v range 0 pst) c ...))
((_ "z" f b e (x in xs) c ...)
(do ((t xs (cdr t))) ((null? t) b)
(let ((x (car t)))
(fold-of "z" f b e c ...))))
((_ "z" f b e (x is y) c ...)
(let ((x y)) (fold-of "z" f b e c ...)))
((_ "z" f b e p? c ...)
(if p? (fold-of "z" f b e c ...)))
((_ f i e c ...)
(let ((b i)) (fold-of "z" f b e c ...)))))
(define-syntax list-of (syntax-rules ()
((_ arg ...) (reverse (fold-of
(lambda (d a) (cons a d)) '() arg ...)))))
(define (unique eql? xs)
(cond ((null? xs) '())
((null? (cdr xs)) xs)
((eql? (car xs) (cadr xs))
(unique eql? (cdr xs)))
(else (cons (car xs) (unique eql? (cdr xs))))))
(define (julian year month day)
(let* ((a (quotient (- 14 month) 12))
(y (+ year 4800 (- a)))
(m (+ month (* 12 a) -3)))
(+ day
(quotient (+ (* 153 m) 2) 5)
(* 365 y)
(quotient y 4)
(- (quotient y 100))
(quotient y 400)
(- 32045))))
(define (list-minus xs ys)
(let loop ((xs xs) (zs (list)))
(cond ((null? xs) zs)
((member (car xs) ys) (loop (cdr xs) zs))
(else (loop (cdr xs) (cons (car xs) zs))))))
(display (list-of (list m y)
(y range 1900 2101)
(m in '(1 3 5 7 8 10 12))
(= (modulo (julian y m 1) 7) 4)))
(newline)
(display (length (list-of (list m y)
(y range 1900 2101)
(m in '(1 3 5 7 8 10 12))
(= (modulo (julian y m 1) 7) 4))))
(newline)
(display (reverse (list-minus (range 1900 2101) (unique =
(list-of y
(y range 1900 2101)
(m in '(1 3 5 7 8 10 12))
(= (modulo (julian y m 1) 7) 4))))))
(newline)
(display (length (list-minus (range 1900 2101) (unique =
(list-of y
(y range 1900 2101)
(m in '(1 3 5 7 8 10 12))
(= (modulo (julian y m 1) 7) 4))))))
(newline)