PasteRack.org
Paste # 50411
2018-01-06 19:26:42

Forked from paste # 10330.

Fork as a new paste.

Paste viewed 233 times.


Embed:

  1. #lang racket
  2. (require (for-syntax racket/list))
  3.  
  4. (struct matrix
  5.   (columns rows elements)
  6.   #:transparent)
  7.  
  8. (begin-for-syntax
  9.   (define (all-same-length lists)
  10.     (define first-length (length (car lists)))
  11.     (define rest (cdr lists))
  12.     (andmap (lambda (l) (eq? first-length (length l)))
  13.             rest))
  14.  
  15.   (define (transpose lists)
  16.     (cond
  17.       [(or (empty? lists)
  18.            (empty? (car lists)))
  19.        '()]
  20.       [else
  21.        (let ([rest (transpose (map cdr lists))])
  22.          (cons (map car lists) rest))]))
  23.  
  24.   (define (transpose-flatten lists)
  25.     (flatten (transpose lists))))
  26.  
  27. (define-syntax (make-matrix stx)
  28.   (syntax-case stx ()
  29.     [(_ [[xs ...] ...])
  30.      (begin
  31.        (let ([data (map syntax->list (syntax->list #'((xs ...) ...)))])
  32.          (when (or (empty? data)
  33.                    (not (all-same-length data)))
  34.            (raise-syntax-error #f
  35.                                "Matrix row lengths not all the same"
  36.                                stx))
  37.          (let ([cols (length data)]
  38.                [rows (length (car data))])
  39.            #`(matrix #,cols #,rows #,(list->vector (transpose-flatten data))))))]))
  40.  
  41. (matrix 3 2 '#(1 3 5 2 4 6))

=>

(matrix 3 2 '#(1 3 5 2 4 6))