fork download
copy 
  1. ; matrix rotation
  2.  
  3. (define (make-matrix rows columns . value)
  4.   (do ((m (make-vector rows)) (i 0 (+ i 1)))
  5.       ((= i rows) m)
  6.     (if (null? value)
  7.         (vector-set! m i (make-vector columns))
  8.         (vector-set! m i (make-vector columns (car value))))))
  9.  
  10. (define (matrix-rows x) (vector-length x))
  11.  
  12. (define (matrix-cols x) (vector-length (vector-ref x 0)))
  13.  
  14. (define (matrix-ref m i j) (vector-ref (vector-ref m i) j))
  15.  
  16. (define (matrix-set! m i j x) (vector-set! (vector-ref m i) j x))
  17.  
  18. (define-syntax for
  19.   (syntax-rules ()
  20.     ((for (var first past step) body ...)
  21.       (let ((ge? (if (< first past) >= <=)))
  22.         (do ((var first (+ var step)))
  23.             ((ge? var past))
  24.           body ...)))
  25.     ((for (var first past) body ...)
  26.       (let* ((f first) (p past) (s (if (< first past) 1 -1)))
  27.         (for (var f p s) body ...)))
  28.     ((for (var past) body ...)
  29.       (let* ((p past)) (for (var 0 p) body ...)))))
  30.  
  31. (define (rotate source)
  32.   (let* ((n (matrix-rows source))
  33.          (m (matrix-cols source))
  34.          (target (make-matrix m n)))
  35.     (for (i 0 m)
  36.       (for (j 0 n)
  37.         (matrix-set! target i j
  38.           (matrix-ref source (- n j 1) i))))
  39.     target))
  40.  
  41. (define m '#( #(a b c) #(d e f) #(g h i) #(j k l) #(m n o)))
  42. (display (rotate m)) (newline)
  43.  
  44. (define (rotate! m)
  45.   (define (rot4 m topleft topright botleft botright)
  46.     (let ((t (matrix-ref m (car botright) (cdr botright))))
  47.       (matrix-set! m (car botright) (cdr botright)
  48.         (matrix-ref m (car botleft) (cdr botleft)))
  49.       (matrix-set! m (car botleft) (cdr botleft)
  50.         (matrix-ref m (car topright) (cdr topright)))
  51.       (matrix-set! m (car topright) (cdr topright)
  52.         (matrix-ref m (car topleft) (cdr topleft)))
  53.       (matrix-set! m (car topleft) (car topright) t)))
  54.   (let ((n (matrix-rows m)))
  55.     (for (i 0 (quotient n 2))
  56.       (let ((top i) (bottom (- n i 1))
  57.             (left i) (right (- n i 1)))
  58.         (for (j 0 (- n i i 1))
  59.           (rot4 m (cons top (+ left j))
  60.                   (cons (+ top j) right)
  61.                   (cons bottom (- right j))
  62.                   (cons (- bottom j) left)))))
  63.     m))
  64.  
  65. (define m '#( #(a b c d e) #(f g h i j) #(k l m n o) #(p q r s t) #(u v w x y)))
  66. (display (rotate! m)) (newline)
  67. (display (rotate! m)) (newline)
  68. (display (rotate! m)) (newline)
  69. (display (rotate! m)) (newline)
Success #stdin #stdout 0.02s 43200KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
#(#(m j g d a) #(n k h e b) #(o l i f c))
#(#(u p k f a) #(v q l g b) #(w r m h c) #(x s n i d) #(y t o j e))
#(#(y x w v u) #(t s r q p) #(o n m l k) #(j i h g f) #(e d c b a))
#(#(e j o t y) #(d i n s x) #(c h m r w) #(b g l q v) #(a f k p u))
#(#(a b c d e) #(f g h i j) #(k l m n o) #(p q r s t) #(u v w x y))
https://ideone.com/UoKFU2
language:
Scheme (guile 2.2.4)
created:
6 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!