codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; lucas sequences (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 (read-line . port) (define (eat p c) (if (and (not (eof-object? (peek-char p))) (char=? (peek-char p) c)) (read-char p))) (let ((p (if (null? port) (current-input-port) (car port)))) (let loop ((c (read-char p)) (line '())) (cond ((eof-object? c) (if (null? line) c (list->string (reverse line)))) ((char=? #\newline c) (eat p #\return) (list->string (reverse line))) ((char=? #\return c) (eat p #\newline) (list->string (reverse line))) (else (loop (read-char p) (cons c line))))))) (define (string-split sep str) (define (f cs xs) (cons (list->string (reverse cs)) xs)) (let loop ((ss (string->list str)) (cs '()) (xs '())) (cond ((null? ss) (reverse (if (null? cs) xs (f cs xs)))) ((char=? (car ss) sep) (loop (cdr ss) '() (f cs xs))) (else (loop (cdr ss) (cons (car ss) cs) xs))))) (define (string-join sep ss) (define (f s ss) (string-append s (string sep) ss)) (define (join ss) (if (null? (cdr ss)) (car ss) (f (car ss) (join (cdr ss))))) (if (null? ss) "" (join ss))) (define-syntax assert (syntax-rules () ((assert expr result) (if (not (equal? expr result)) (for-each display `( #\newline "failed assertion:" #\newline expr #\newline "expected: " ,result #\newline "returned: " ,expr #\newline)))))) (define (tempname) (let loop ((i 0)) (let ((f (string-append "temp" (number->string i)))) (if (file-exists? f) (loop (+ i 1)) f)))) (define wget "/usr/bin/wget -q -O") (define (with-input-from-url url thunk) (let ((f (tempname))) (if (zero? (system (string-append wget " " f " \"" url "\""))) (begin (with-input-from-file f thunk) );(delete-file f #t)) (error 'with-input-from-url "system error in wget")))) (define (lseq p q x0 x1 n) (let loop ((x0 x0) (x1 x1) (k 1) (xs (list x1 x0))) (if (= k n) (reverse xs) (let ((x2 (- (* p x1) (* q x0)))) (loop x1 x2 (+ k 1) (cons x2 xs)))))) (define (lucas p q m n) (define (mod n) (if (zero? m) n (modulo n m))) (let bits ((n n) (bs (list))) (if (positive? n) (bits (quotient n 2) (cons (modulo n 2) bs)) (let loop ((un 0) (uu 1) (vn 2) (vv p) (qn 1) (bs bs)) (cond ((null? bs) (values un vn qn)) ((odd? (car bs)) ; 1-bit (loop (mod (- (* uu vn) qn)) ; u(2n+1) (mod (* uu vv)) ; u(2n+2) (mod (- (* vv vn) (* p qn))) ; v(2n+1) (mod (- (* vv vv) (* 2 q qn))) ; v(2n+2) (mod (* qn qn q)) (cdr bs))) (else ; 0-bit (loop (mod (* un vn)) ; u(2n) (mod (- (* uu vn) qn)) ; u(2n+1) (mod (- (* vn vn) (* 2 qn))) ; v(2n) (mod (- (* vv vn) (* p qn))) ; v(2n+1) (mod (* qn qn)) (cdr bs)))))))) (define (u p q n) (call-with-values (lambda () (lucas p q 0 n)) (lambda (un vn qn) un))) (define (v p q n) (call-with-values (lambda () (lucas p q 0 n)) (lambda (un vn qn) vn))) (define (test1) (do ((p -10 (+ p 1))) ((< 10 p)) (do ((q -10 (+ q 1))) ((< 10 q)) (display "P=") (display p) (display ", Q=") (display q) (newline) (assert (lseq p q 0 1 100) (map (lambda (n) (u p q n)) (range 101))) (assert (lseq p q 2 p 100) (map (lambda (n) (v p q n)) (range 101)))))) (test1) (define (get-oeis seq) (with-input-from-url (string-append "http://oeis.org/search?q=id:" seq "&fmt=text") (lambda () (let ((seq-str "")) (do ((line (read-line) (read-line))) ((eof-object? line) (map string->number (string-split #\, seq-str))) (when (< 2 (string-length line)) (case (substring line 0 2) (("%S" "%T" "%U") (let ((fields (string-split #\space line))) (set! seq-str (string-append seq-str (caddr fields))))) (("%V") (let ((fields (string-split #\space line))) (set! seq-str (caddr fields)))) (("%W" "%X") (let ((fields (string-split #\space line))) (set! seq-str (string-append seq-str (caddr fields)))))))))))) (define (check-lucas p q u-or-v seq) (display seq) (newline) (let loop ((ss (get-oeis seq)) (n 0)) (when (pair? ss) (if (eq? u-or-v 'u) (assert (u p q n) (car ss)) (assert (v p q n) (car ss))) (loop (cdr ss) (+ n 1))))) (define oeis-lucas '((-1 3 u "A214733") (1 -1 u "A000045") (1 -1 v "A000032") (1 1 u "A128834") ( 1 1 v "A087204") (1 2 u "A107920") (2 -1 u "A000129") (2 -1 v "A002203") ( 2 1 u "A001477") (2 2 u "A009545") (2 2 v "A007395") (2 3 u "A088137") ( 2 4 u "A088138") (2 5 u "A045873") (3 -5 u "A015523") (3 -5 v "A072263") ( 3 -4 u "A015521") (3 -4 v "A201455") (3 -3 u "A030195") (3 -3 v "A172012") ( 3 -2 v "A206776") (3 -1 u "A006190") (3 -1 v "A006497") (3 1 u "A001906") ( 3 1 v "A005248") (3 2 u "A000225") (3 2 v "A000051") (3 5 u "A190959") ( 4 -3 u "A015530") (4 -3 v "A080042") (4 -2 u "A090017") (4 -1 u "A001076") ( 4 -1 v "A014448") (4 1 u "A001353") (4 1 v "A003500") (4 2 v "A056236") ( 4 3 u "A003462") (4 3 v "A034472") (4 4 u "A001787") (5 -3 u "A015536") ( 5 -2 u "A015535") (5 -1 v "A087130") (5 1 v "A003501") (5 4 u "A002450") ( 5 4 v "A052539"))) (define (test2) (for-each (lambda (t) (apply check-lucas t)) oeis-lucas)) (test2)
Private
[
?
]
Run code
Submit