codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; magic squares (define (make-matrix rows columns . value) (do ((m (make-vector rows)) (i 0 (+ i 1))) ((= i rows) m) (if (null? value) (vector-set! m i (make-vector columns)) (vector-set! m i (make-vector columns (car value)))))) (define (matrix-rows x) (vector-length x)) (define (matrix-cols x) (vector-length (vector-ref x 0))) (define (matrix-ref m i j) (vector-ref (vector-ref m i) j)) (define (matrix-set! m i j x) (vector-set! (vector-ref m i) j x)) (define-syntax for (syntax-rules () ((for (var first past step) body ...) (let ((ge? (if (< first past) >= <=))) (do ((var first (+ var step))) ((ge? var past)) body ...))) ((for (var first past) body ...) (let* ((f first) (p past) (s (if (< first past) 1 -1))) (for (var f p s) body ...))) ((for (var past) body ...) (let* ((p past)) (for (var 0 p) body ...))))) (define (digits n . args) (let ((b (if (null? args) 10 (car args)))) (let loop ((n n) (d '())) (if (zero? n) d (loop (quotient n b) (cons (modulo n b) d)))))) (define (digit->char d) (integer->char (+ d 48))) (define (rept n . cs) (make-string n (if (pair? cs) (car cs) #\space))) (define (align str wid aline) (let ((len (string-length str))) (cond ((< wid len) (rept wid #\#)) ((eq? aline'left) (string-append str (rept (- wid len)))) ((eq? aline 'center) (let* ((left (quotient (- wid len) 2)) (right (- wid len left))) (string-append (rept left) str (rept right)))) ((eq? aline 'right) (string-append (rept (- wid len)) str)) (else (error 'align "invalid alignment specifier"))))) (define (number->decimal num wid . aline) (if (not (integer? num)) (error 'number->decimal "invalid input") (let ((aline (if (pair? aline) (car aline) 'right)) (sign (if (negative? num) "-" (if (zero? num) "0" ""))) (num (list->string (map digit->char (digits (abs num)))))) (align (string-append sign num) wid aline)))) (define (magic n start up/down left/right dir) (define (incr x) (modulo (+ x 1) n)) (define (decr x) (modulo (- x 1) n)) (let ((square (make-matrix n n 0)) (row (cond ((eq? start 'top) 0) ((eq? start 'bottom) (- n 1)) (else (quotient n 2)))) (col (cond ((eq? start 'left) 0) ((eq? start 'right) (- n 1)) (else (quotient n 2))))) (let loop ((i 1) (row row) (col col)) (if (< (* n n) i) square (let ((next-row (if (eq? up/down 'up) (decr row) (incr row))) (next-col (if (eq? left/right 'left) (decr col) (incr col)))) (when (positive? (matrix-ref square next-row next-col)) (cond ((eq? dir 'up) (set! next-row (decr row)) (set! next-col col)) ((eq? dir 'down) (set! next-row (incr row)) (set! next-col col)) ((eq? dir 'left) (set! next-row row) (set! next-col (decr col))) ((eq? dir 'right) (set! next-row row) (set! next-col (incr col))))) (matrix-set! square row col i) (loop (+ i 1) next-row next-col)))))) (display (magic 3 'top 'up 'left 'down)) (newline) (display (magic 3 'top 'up 'right 'down)) (newline) (display (magic 3 'left 'left 'up 'right)) (newline) (display (magic 3 'left 'left 'down 'right)) (newline) (display (magic 3 'right 'right 'up 'left)) (newline) (display (magic 3 'right 'right 'down 'left)) (newline) (display (magic 3 'bottom 'down 'left 'up)) (newline) (display (magic 3 'bottom 'down 'right 'up)) (newline) (define (display-square square) (let* ((n (matrix-rows square)) (width (+ (string-length (number->string (* n n))) 1))) (for (r 0 n) (for (c 0 n) (display (number->decimal (matrix-ref square r c) width 'right))) (newline)))) (display-square (magic 13 'top 'up 'left 'down))
Private
[
?
]
Run code
Submit