external/clem/src/typed-ops/defmatrix-equal.lisp

   1 ;;; -*- Mode: lisp; outline-regexp: ";;;;;*"; indent-tabs-mode: nil -*-;;;
   2 ;;;
   3 ;;; file: defmatrix-equal.cl
   4 ;;; author: cyrus harmon
   5 ;;;
   6
   7 (in-package :clem)
   8
   9 (defmacro def-matrix-equal (type-1 type-2 &key suffix)
  10   (let ((element-type-1 (element-type (find-class `,type-1)))
  11         (element-type-2 (element-type (find-class `,type-2))))
  12     `(progn
  13        (defmethod ,(ch-util:make-intern (concatenate 'string "mat-equal-range" suffix))
  14            ((m ,type-1) (n ,type-2) startr endr startc endc)
  15          (let ((equal t))
  16            (clem::mloop-range (((m ,element-type-1 a)
  17                                 (n ,element-type-2 b))
  18                                startr endr startc endc i j)
  19              (setf equal (and equal (= (aref a i j) (aref b i j)))))
  20            equal))
  21
  22        (defmethod ,(ch-util:make-intern (concatenate 'string "mat-equal" suffix))
  23            ((m ,type-1) (n ,type-2))
  24          (destructuring-bind (mr mc) (dim m)
  25            (,(ch-util:make-intern (concatenate 'string "mat-equal-range" suffix)) m n 0 (1- mr) 0 (1- mc)))))))
  26
  27 (macrolet ((frob (type-1 type-2 &key suffix)
  28              `(progn
  29                 (def-matrix-equal ,type-1 ,type-2 :suffix ,suffix))))
  30
  31   (frob double-float-matrix double-float-matrix)
  32   (frob single-float-matrix single-float-matrix)
  33
  34   (frob ub8-matrix ub8-matrix)
  35   (frob ub16-matrix ub16-matrix)
  36   (frob ub32-matrix ub32-matrix)
  37
  38   (frob sb8-matrix sb8-matrix)
  39   (frob sb16-matrix sb16-matrix)
  40   (frob sb32-matrix sb32-matrix)
  41
  42   (frob bit-matrix bit-matrix)
  43
  44   (frob real-matrix real-matrix)
  45   (frob integer-matrix integer-matrix)
  46
  47   (frob complex-matrix complex-matrix))
  48