; highly abundant numbers

(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 (add1 n) (+ n 1))

(define (factors n) ; factors of n in increasing order by 2,3,5-wheel
  (define (last-pair xs) (if (null? (cdr xs)) xs (last-pair (cdr xs))))
  (define (cycle . xs) (set-cdr! (last-pair xs) xs) xs)
  (define wheel (cons 1 (cons 2 (cons 2 (cycle 4 2 4 2 4 6 2 6)))))
  (let loop ((n n) (f 2) (wheel wheel) (fs (list)))
    (if (< n (* f f)) (reverse (cons n fs))
      (if (zero? (modulo n f)) (loop (/ n f) f wheel (cons f fs))
        (loop n (+ f (car wheel)) (cdr wheel) fs)))))

(define (sigma n) ; sum of divisors of n
  (if (= n 1) 1
    (let ((fs (factors n)))
      (let loop ((fs (cdr fs)) (f (car fs)) (prod (car fs)) (sum 1))
        (if (null? fs) (* sum (/ (- (* prod f) 1) (- f 1)))
          (if (= (car fs) f) (loop (cdr fs) f (* prod f) sum)
            (loop (cdr fs) (car fs) (car fs)
                  (* sum (/ (- (* prod f) 1) (- f 1))))))))))

(define (records lt? xs) ; index and value at each new maximum
  (if (null? xs) (error 'records "no data")
    (let loop ((xs (cdr xs)) (k 1) (recs (list (cons 0 (car xs)))))
      (if (null? xs) (reverse recs)
        (if (lt? (cdar recs) (car xs))
            (loop (cdr xs) (+ k 1) (cons (cons k (car xs)) recs))
            (loop (cdr xs) (+ k 1) recs))))))

(define (hans n)
  (map add1 (map car (records < (map sigma (range 1 (+ n 1)))))))

(display (hans 2100)) (newline)