codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; how fermat factored integers (define (sprintf fmt . args) (define (escape cs) (define (octal? c) (char<=? #\0 c #\7)) (define (c->o c) (- (char->integer c) 48)) (cond ((null? cs) (error 'escape "incomplete")) ((not (char=? (car cs) #\\)) (values (car cs) (cdr cs))) ((null? (cdr cs)) (error 'escape "malformed")) ((char=? (cadr cs) #\b) (values #\backspace (cddr cs))) ((char=? (cadr cs) #\f) (values #\page (cddr cs))) ((char=? (cadr cs) #\n) (values #\newline (cddr cs))) ((char=? (cadr cs) #\r) (values #\return (cddr cs))) ((char=? (cadr cs) #\t) (values #\tab (cddr cs))) ((octal? (cadr cs)) (let loop ((k 3) (cs (cdr cs)) (oct 0)) (if (and (positive? k) (pair? cs) (octal? (car cs))) (loop (- k 1) (cdr cs) (+ (* oct 8) (c->o (car cs)))) (values (integer->char oct) cs)))) (else (values (cadr cs) (cddr cs))))) (define (specifier cs arg) (define (c->d c) (- (char->integer c) 48)) (define (justify str left? pad? width) (let ((len (string-length str))) (cond ((<= width len) str) (left? (string-append str (make-string (- width len) #\space))) ((and pad? (not left?)) (string-append (make-string (- width len) #\0) str)) (else (string-append (make-string (- width len) #\space) str))))) (define (rnd num prec) (if prec (/ (round (* num (expt 10 prec))) (expt 10 prec)) num)) (define (trunc num) (inexact->exact (truncate num))) (let ((cs (cdr cs)) (left? #f) (pad? #f) (width 0) (prec #f)) (when (and (pair? cs) (char=? (car cs) #\-)) (set! left? #t) (set! cs (cdr cs))) (when (and (pair? cs) (char=? (car cs) #\0)) (set! pad? #t) (set! cs (cdr cs))) (do () ((or (null? cs) (not (char-numeric? (car cs))))) (set! width (+ (* width 10) (c->d (car cs)))) (set! cs (cdr cs))) (when (and (pair? cs) (char=? (car cs) #\.)) (set! cs (cdr cs)) (set! prec 0) (do () ((or (null? cs) (not (char-numeric? (car cs))))) (set! prec (+ (* prec 10) (c->d (car cs)))) (set! cs (cdr cs)))) (if (null? cs) (error 'specifier "incomplete") (case (car cs) ((#\c) (values (justify (string (integer->char arg)) left? #f width) (cdr cs))) ((#\d) (values (justify (number->string (trunc arg)) left? pad? width) (cdr cs))) ((#\f) (values (justify (number->string (rnd arg prec)) left? pad? width) (cdr cs))) ((#\o) (values (justify (number->string (trunc arg) 8) left? pad? width) (cdr cs))) ((#\s) (values (justify (if prec (substring arg 0 prec) arg) left? #f width) (cdr cs))) ((#\x) (values (justify (number->string (trunc arg) 16) left? pad? width) (cdr cs))) (else (error 'specifier "unsupported")))))) (let loop ((cs (string->list fmt)) (args args) (out (list))) (cond ((null? cs) (if (pair? args) (error 'printf "too many arguments") (list->string (reverse out)))) ((char=? (car cs) #\\) (call-with-values (lambda () (escape cs)) (lambda (c rest) (loop rest args (cons c out))))) ((char=? (car cs) #\%) (if (null? (cdr cs)) (error 'sprintf "incomplete specifier") (if (char=? (cadr cs) #\%) (loop (cddr cs) args (cons #\% out)) (if (null? args) (error 'printf "not enough arguments") (call-with-values (lambda () (specifier cs (car args))) (lambda (str rest) (loop rest (cdr args) (append (reverse (string->list str)) out)))))))) (else (loop (cdr cs) args (cons (car cs) out)))))) (define (printf fmt . args) (display (apply sprintf fmt args))) (define limit 10000) (define squares (let ((squares (make-vector (+ limit 1)))) (do ((i 0 (+ i 1))) ((< limit i) squares) (vector-set! squares i (* i i))))) (define (isqrt n) (do ((i 1 (+ i 1))) ((< n (vector-ref squares i)) (- i 1)))) (define (in-table n) (let loop ((i 0)) (cond ((< n (vector-ref squares i)) #f) ((= n (vector-ref squares i)) i) (else (loop (+ i 1)))))) (define (digital-root n) (let loop ((n n) (r 0)) (cond ((zero? n) (if (< r 10) r (digital-root r))) ((< n 10) (loop 0 (+ r n))) (else (let ((d (modulo n 10))) (loop (/ (- n d) 10) (+ r d))))))) (define (square? n) (let* ((ones (modulo n 10)) (tens (modulo (/ (- n ones) 10) 10))) (and (or (and (= 0 ones) (zero? tens)) (and (= 1 ones) (even? tens)) (and (= 4 ones) (even? tens)) (and (= 5 ones) (= 2 tens)) (and (= 6 ones) (odd? tens)) (and (= 9 ones) (even? tens))) (member (digital-root n) '(1 4 7 9)) (in-table n)))) (define (fermat n) (if (not (< -1 n (* limit limit))) #f (if (even? n) (list 2 (/ n 2)) (let ((x (isqrt n))) (if (= (* x x) n) (list x x) (let loop ((r (- (* x x) n)) (t (+ x x 1))) (display r) (display " ") (display t) (newline) (if (not (square? r)) (loop (+ r t) (+ t 2)) (let ((x (/ (- t 1) 2)) (y (isqrt r))) (list (- x y) (+ x y)))))))))) (display (fermat 13290059)) (newline) (newline) ; print table of squares to a million (begin (define (square x) (* x x)) (define (print-header) (printf "--- ------ ------ ------ ------ ------ ------ ------ ------ ------\n") (printf " 1 2 3 4 5 6 7 8 9\n") (printf "--- ------ ------ ------ ------ ------ ------ ------ ------ ------\n")) (do ((tens 0 (+ tens 1))) ((= tens 100)) (when (zero? (modulo tens 10)) (print-header)) (printf "%3d" (* tens 10)) (do ((ones 1 (+ ones 1))) ((= ones 10)) (printf " %6d" (square (+ (* tens 10) ones)))) (printf "\n")) (print-header))
Private
[
?
]
Run code
Submit