[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Nov 27:
; divisors and totients

(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 (filter pred? xs)
  (let loop ((xs xs) (ys '()))
    (cond ((null? xs) (reverse ys))
          ((pred? (car xs))
            (loop (cdr xs) (cons (car xs) ys)))
          (else (loop (cdr xs) ys)))))

(define (sum xs) (apply + xs))

(define (product xs) (apply * xs))

(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 (uniq-c eql? xs)
  (if (null? xs) xs
    (let loop ((xs (cdr xs)) (prev (car xs)) (k 1) (result '()))
      (cond ((null? xs) (reverse (cons (cons prev k) result)))
            ((eql? (car xs) prev) (loop (cdr xs) prev (+ k 1) result))
            (else (loop (cdr xs) (car xs) 1 (cons (cons prev k) result)))))))

(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 (divisors n)
  (unique = (sort < (map product (subsets (factors n))))))

(define (sumdiv n) (sum (divisors n)))

(define (numdiv n)
  (apply * (map add1 (map cdr (uniq-c = (factors n))))))

(define (totatives n)
  (filter (lambda (x) (= (gcd n x) 1)) (range 1 n)))

(define (totient n)
  (product (cons n (map (lambda (x) (- 1 (/ x))) (unique = (factors n))))))

(display (divisors 60)) (newline)
(display (sumdiv 60)) (newline)
(display (numdiv 60)) (newline)

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


Output:
1
2
3
4
5
(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: