[ create a new paste ] login | about

Link: http://codepad.org/fW3wzmKI    [ raw code | output | fork ]

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


Output:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
#(#(6 1 8) #(7 5 3) #(2 9 4))
#(#(8 1 6) #(3 5 7) #(4 9 2))
#(#(4 8 3) #(1 5 9) #(7 2 6))
#(#(4 8 3) #(1 5 9) #(7 2 6))
#(#(4 3 8) #(9 5 1) #(2 7 6))
#(#(4 3 8) #(9 5 1) #(2 7 6))
#(#(2 9 4) #(7 5 3) #(6 1 8))
#(#(4 9 2) #(3 5 7) #(8 1 6))
  91  76  61  46  31  16   1 168 153 138 123 108  93
  92  90  75  60  45  30  15  13 167 152 137 122 107
 106 104  89  74  59  44  29  14  12 166 151 136 121
 120 105 103  88  73  58  43  28  26  11 165 150 135
 134 119 117 102  87  72  57  42  27  25  10 164 149
 148 133 118 116 101  86  71  56  41  39  24   9 163
 162 147 132 130 115 100  85  70  55  40  38  23   8
   7 161 146 131 129 114  99  84  69  54  52  37  22
  21   6 160 145 143 128 113  98  83  68  53  51  36
  35  20   5 159 144 142 127 112  97  82  67  65  50
  49  34  19   4 158 156 141 126 111  96  81  66  64
  63  48  33  18   3 157 155 140 125 110  95  80  78
  77  62  47  32  17   2 169 154 139 124 109  94  79


Create a new paste based on this one


Comments: