[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/SmASe1eC    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Nov 25:
; divisors and totatives

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(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 (subsets s)
  (if (null? s) (list ())
    (let ((rest (subsets (cdr s))))
      (append rest (map (lambda (x) (cons (car s) x)) rest)))))

(define (factors n)
  (if (even? n) (cons 2 (factors (/ n 2)))
    (let loop ((n n) (f 3) (fs '()))
      (cond ((< n (* f f)) (reverse (cons n fs)))
            ((zero? (modulo n f)) (loop (/ n f) f (cons f fs)))
            (else (loop n (+ f 2) fs))))))

(define (divisors1 n)
  (define (prod xs) (apply * xs))
  (define (cons1 xs) (cons 1 xs))
  (unique = (sort <
    (map prod (map cons1
      (subsets (factors n)))))))

(define (divisors2 n)
  (define (times x) (lambda (y) (* x y)))
  (let divs ((fs (factors n)))
    (unique = (sort <
      (if (null? fs) '(1)
        (let ((ds (divs (cdr fs))))
          (append ds (map (times (car fs)) ds))))))))

(define divisors divisors1)

(define (sumdiv n) (apply + (divisors n)))

(define (numdiv n)
  (let ((fs (factors n)))
    (let loop ((prev (car fs)) (fs (cdr fs)) (f 2) (d 1))
      (cond ((null? fs) (* d f))
            ((= (car fs) prev) (loop prev (cdr fs) (+ f 1) d))
            (else (loop (car fs) (cdr fs) 2 (* d f)))))))

(define (totatives n)
  (let loop ((t n) (ts '()))
    (cond ((= t 1) (cons 1 ts))
          ((= (gcd t n) 1) (loop (- t 1) (cons t ts)))
          (else (loop (- t 1) ts)))))

(define (totient n)
  (let loop  ((fs (unique = (factors n))) (t n))
    (if (null? fs) t
      (loop (cdr fs) (* t (- 1 (/ (car fs))))))))

(display (divisors1 60)) (newline)
(display (divisors2 60)) (newline)
(display (sumdiv 60)) (newline)
(display (numdiv 60)) (newline)

(display (totatives 30)) (newline)
(display (totient 30)) (newline)


Output:
1
2
3
4
5
6
(1 2 3 4 5 6 10 12 15 20 30 60)
(1 2 3 4 5 6 10 12 15 20 30 60)
168
12
(1 7 11 13 17 19 23 29)
8


Create a new paste based on this one


Comments: