; 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))
programmingpraxis
-
Scheme,
pasted
on Jul 17: