Permalink
Browse files

Merge branch 'master' of git+ssh://git.cyrusharmon.org/pub/git/clem

  • Loading branch information...
2 parents be59c58 + 2288b47 commit b59cbfcf9e358654fbf063049f750c9658dc3983 @slyrus committed Jun 11, 2010
View
@@ -5,10 +5,8 @@
(defsystem :clem-benchmark
:name "clem-benchmark"
:author "Cyrus Harmon <ch-lisp@bobobeach.com>"
- :version #.(with-open-file
- (vers (merge-pathnames "version.lisp-expr" *load-truename*))
- (read vers))
- :depends-on (ch-util clem)
+ :version "0.4.8"
+ :depends-on (clem)
:components
((:module :benchmark
:components
View
@@ -10,9 +10,7 @@
(defsystem :clem-doc
:name "clem-doc"
:author "Cyrus Harmon"
- :version #.(with-open-file
- (vers (merge-pathnames "version.lisp-expr" *load-truename*))
- (read vers))
+ :version "0.4.8"
:licence "BSD"
:depends-on (ch-asdf ch-bib ch-util clem smarkup)
:components
View
@@ -2,20 +2,19 @@
(asdf:defsystem :clem-test
:name "clem-test"
:author "Cyrus Harmon <ch-lisp@bobobeach.com>"
- :version #.(with-open-file
- (vers (merge-pathnames "version.lisp-expr" *load-truename*))
- (read vers))
- :depends-on (ch-util clem)
+ :version "0.4.8"
+ :depends-on (clem)
:components
((:module :test
:components
((:cl-source-file "defpackage")
- (:cl-source-file "test-clem" :depends-on ("defpackage"))
- (:cl-source-file "test-clem2" :depends-on ("defpackage"))
- (:cl-source-file "test-clem3" :depends-on ("defpackage"))
- (:cl-source-file "test-defmatrix" :depends-on ("defpackage"))
- (:cl-source-file "test-transform" :depends-on ("defpackage"))
- (:cl-source-file "test-convolve" :depends-on ("defpackage"))
- (:cl-source-file "bench-matrix" :depends-on ("defpackage"))
- (:cl-source-file "test-hprod" :depends-on ("defpackage"))))))
+ (:cl-source-file "testharness" :depends-on ("defpackage"))
+ (:cl-source-file "test-clem" :depends-on ("defpackage" "testharness"))
+ (:cl-source-file "test-clem2" :depends-on ("defpackage" "testharness"))
+ (:cl-source-file "test-clem3" :depends-on ("defpackage" "testharness"))
+ (:cl-source-file "test-defmatrix" :depends-on ("defpackage" "testharness"))
+ (:cl-source-file "test-transform" :depends-on ("defpackage" "testharness"))
+ (:cl-source-file "test-convolve" :depends-on ("defpackage" "testharness"))
+ (:cl-source-file "bench-matrix" :depends-on ("defpackage" "testharness"))
+ (:cl-source-file "test-hprod" :depends-on ("defpackage" "testharness"))))))
View
@@ -2,17 +2,14 @@
(asdf:defsystem :clem
:name "clem"
:author "Cyrus Harmon <ch-lisp@bobobeach.com>"
- :version #.(with-open-file
- (vers (merge-pathnames "version.lisp-expr" *load-truename*))
- (read vers))
+ :version "0.4.8"
:licence "BSD"
- :depends-on (ch-util)
:components
- ((:static-file "version" :pathname #p"version.lisp-expr")
- (:module
+ ((:module
:src
:components
((:cl-source-file "defpackage")
+ (:cl-source-file "utilities" :depends-on ("defpackage"))
(:cl-source-file "metaclasses" :depends-on ("defpackage"))
(:cl-source-file "early-matrix" :depends-on ("defpackage" "metaclasses"))
(:cl-source-file "mref" :depends-on ("early-matrix"))
@@ -21,7 +18,7 @@
"metaclasses"
"mref"
"macros"))
- (:cl-source-file "matrix" :depends-on ("matrix-classes"))
+ (:cl-source-file "matrix" :depends-on ("matrix-classes" "utilities"))
(:cl-source-file "print" :depends-on ("matrix"))
(:cl-source-file "typed-matrix" :depends-on ("defpackage" "matrix"))
(:cl-source-file "mloop" :depends-on ("defpackage" "matrix"))
View
@@ -41,7 +41,7 @@
(let ((element-type-1 (element-type (find-class `,type-1)))
(accumulator-element-type (element-type (find-class `,accumulator-type))))
`(progn
- (defmethod ,(ch-util:make-intern (concatenate 'string "mat-abs-range" suffix))
+ (defmethod ,(make-intern (concatenate 'string "mat-abs-range" suffix))
((m ,type-1) startr endr startc endc)
(destructuring-bind (mr mc) (dim m)
(let ((p (make-instance ',accumulator-type :rows mr :cols mc)))
@@ -57,16 +57,16 @@
(abs (aref a i j)))))))
p)))
- (defmethod ,(ch-util:make-intern (concatenate 'string "mat-abs" suffix))
+ (defmethod ,(make-intern (concatenate 'string "mat-abs" suffix))
((m ,type-1))
(destructuring-bind (mr mc) (dim m)
- (,(ch-util:make-intern (concatenate 'string "mat-abs-range" suffix))
+ (,(make-intern (concatenate 'string "mat-abs-range" suffix))
m 0 (1- mr) 0 (1- mc)))))))
(defmacro def-matrix-abs! (type-1 &key suffix)
(let ((element-type-1 (element-type (find-class `,type-1))))
`(progn
- (defmethod ,(ch-util:make-intern (concatenate 'string "mat-abs-range!" suffix))
+ (defmethod ,(make-intern (concatenate 'string "mat-abs-range!" suffix))
((m ,type-1) startr endr startc endc)
(with-matrix-vals (m ,element-type-1 a)
(do ((i startr (1+ i)))
@@ -78,10 +78,10 @@
(setf (aref a i j) (abs (aref a i j))))))
m)
- (defmethod ,(ch-util:make-intern (concatenate 'string "mat-abs!" suffix))
+ (defmethod ,(make-intern (concatenate 'string "mat-abs!" suffix))
((m ,type-1))
(destructuring-bind (mr mc) (dim m)
- (,(ch-util:make-intern (concatenate 'string "mat-abs-range!" suffix))
+ (,(make-intern (concatenate 'string "mat-abs-range!" suffix))
m 0 (1- mr) 0 (1- mc)))))))
(macrolet ((frob (type-1 type-2 &key suffix)
View
@@ -43,7 +43,7 @@
(element-type-2 (element-type (find-class `,type-2)))
(accumulator-element-type (element-type (find-class `,accumulator-type))))
`(progn
- (defmethod ,(ch-util:make-intern (concatenate 'string "mat-add-range" suffix))
+ (defmethod ,(make-intern (concatenate 'string "mat-add-range" suffix))
((m ,type-1) (n ,type-2) startr endr startc endc &key in-place)
(destructuring-bind (mr mc) (dim m)
(if in-place
@@ -164,7 +164,7 @@
(let ((element-type-1 (element-type (find-class `,type-1)))
(accumulator-element-type (element-type (find-class `,accumulator-type))))
`(progn
- (defmethod ,(ch-util:make-intern (concatenate 'string "mat-add-range-"
+ (defmethod ,(make-intern (concatenate 'string "mat-add-range-"
(symbol-name type-2)
suffix))
((m ,type-1) n startr endr startc endc &key in-place)
@@ -199,7 +199,7 @@
(+ (mref m i j) n))))))
p))))
- (defmethod ,(ch-util:make-intern (concatenate 'string "mat-add"
+ (defmethod ,(make-intern (concatenate 'string "mat-add"
(symbol-name type-2)
suffix))
((m ,type-1) n &key in-place)
@@ -245,7 +245,7 @@
(element-type-2 (element-type (find-class `,type-2)))
(accumulator-element-type (element-type (find-class `,accumulator-type))))
`(progn
- (defmethod ,(ch-util:make-intern (concatenate 'string "mat-add-range" suffix))
+ (defmethod ,(make-intern (concatenate 'string "mat-add-range" suffix))
((m ,type-1) (n ,type-2) startr endr startc endc &key in-place)
(declare (type ,type-2 n))
(let ((val (clem::scalar-val n)))
@@ -276,7 +276,7 @@
(+ (mref m i j) val))))))
p)))))
- (defmethod ,(ch-util:make-intern (concatenate 'string "mat-add" suffix))
+ (defmethod ,(make-intern (concatenate 'string "mat-add" suffix))
((m ,type-1) (n ,type-2) &key in-place)
(let ((val (clem::scalar-val n)))
(declare (type ,element-type-2 val))
View
@@ -63,9 +63,9 @@
(with-typed-matrix-vals (m ,element-type a)
(setf (aref a row col) v)))
- (defgeneric ,(ch-util:make-intern
+ (defgeneric ,(make-intern
(concatenate 'string "array->" (symbol-name type))) (a))
- (defmethod ,(ch-util:make-intern
+ (defmethod ,(make-intern
(concatenate 'string "array->" (symbol-name type))) ((a array))
(array->matrix a :matrix-class ',type))
@@ -114,10 +114,10 @@
m)
(defgeneric
- ,(ch-util:make-intern (concatenate 'string "random-" (symbol-name type)))
+ ,(make-intern (concatenate 'string "random-" (symbol-name type)))
(rows cols &key max))
(defmethod
- ,(ch-util:make-intern (concatenate 'string "random-" (symbol-name type)))
+ ,(make-intern (concatenate 'string "random-" (symbol-name type)))
(rows cols &key (max nil))
(let ((a (make-instance ',type :rows rows :cols cols))
(maxvalue (if max
View
@@ -9,7 +9,7 @@
(defmacro bilinear-interpolate
(g00 g01 g10 g11 a b)
- (ch-util::once-only (g00 g01 g10 g11 a b)
+ (once-only (g00 g01 g10 g11 a b)
`(+ ,g00
(* ,a (- ,g10 ,g00))
(* ,b (- ,g01 ,g00))
View
@@ -12,7 +12,7 @@
(let ((element-type-1 (element-type (find-class `,type-1)))
(accumulator-element-type (element-type (find-class `,accumulator-type))))
`(progn
- (defmethod ,(ch-util:make-intern (concatenate 'string "mlog-range" suffix))
+ (defmethod ,(make-intern (concatenate 'string "mlog-range" suffix))
((m ,type-1) startr endr startc endc &optional base)
(destructuring-bind (mr mc) (dim m)
(let ((p (make-instance ',accumulator-type :rows mr :cols mc)))
@@ -28,16 +28,16 @@
(apply #'log (mref m i j) (when base (list base))))))))
p)))
- (defmethod ,(ch-util:make-intern (concatenate 'string "mlog" suffix))
+ (defmethod ,(make-intern (concatenate 'string "mlog" suffix))
((m ,type-1) &optional base)
(destructuring-bind (mr mc) (dim m)
- (apply #',(ch-util:make-intern (concatenate 'string "mlog-range" suffix))
+ (apply #',(make-intern (concatenate 'string "mlog-range" suffix))
m 0 (1- mr) 0 (1- mc) (when base (list base))))))))
(defmacro def-matrix-log! (type-1 &key suffix)
(let ((element-type-1 (element-type (find-class `,type-1))))
`(progn
- (defmethod ,(ch-util:make-intern (concatenate 'string "mlog-range!" suffix))
+ (defmethod ,(make-intern (concatenate 'string "mlog-range!" suffix))
((m ,type-1) startr endr startc endc &optional base)
(with-typed-mref (m ,element-type-1)
(do ((i startr (1+ i)))
@@ -49,10 +49,10 @@
(setf (mref m i j) (apply #'log (mref m i j) (when base (list base)))))))
m)
- (defmethod ,(ch-util:make-intern (concatenate 'string "mlog!" suffix))
+ (defmethod ,(make-intern (concatenate 'string "mlog!" suffix))
((m ,type-1) &optional base)
(destructuring-bind (mr mc) (dim m)
- (apply #',(ch-util:make-intern (concatenate 'string "mlog-range!" suffix))
+ (apply #',(make-intern (concatenate 'string "mlog-range!" suffix))
m 0 (1- mr) 0 (1- mc) (when base (list base))))))))
(macrolet ((frob (type-1 type-2 &key suffix)
@@ -67,7 +67,7 @@
(accumulator-element-type (element-type (find-class `,accumulator-type))))
(let ((max (max (maxval class-1) (maxval class-2))))
`(progn
- (defmethod ,(ch-util:make-intern (concatenate 'string name "-range" suffix))
+ (defmethod ,(make-intern (concatenate 'string name "-range" suffix))
((m ,type-1) (n ,type-2) startr endr startc endc)
(destructuring-bind (mr mc) (dim m)
(let ((p (make-instance ',accumulator-type :rows mr :cols mc)))
@@ -84,10 +84,10 @@
(logand ,max (lognor (mref m i j) (mref n i j)))))))))
p)))
- (defmethod ,(ch-util:make-intern (concatenate 'string name suffix))
+ (defmethod ,(make-intern (concatenate 'string name suffix))
((m ,type-1) (n ,type-2))
(destructuring-bind (mr mc) (dim m)
- (,(ch-util:make-intern (concatenate 'string name "-range" suffix)) m n 0 (1- mr) 0 (1- mc)))))))))
+ (,(make-intern (concatenate 'string name "-range" suffix)) m n 0 (1- mr) 0 (1- mc)))))))))
(defmacro defmbitnor! (name type-1 type-2 accumulator-type &key suffix)
(declare (ignore accumulator-type))
@@ -97,7 +97,7 @@
(element-type-2 (element-type class-2)))
(let ((max (max (maxval class-1) (maxval class-2))))
`(progn
- (defmethod ,(ch-util:make-intern (concatenate 'string name "!-range" suffix))
+ (defmethod ,(make-intern (concatenate 'string name "!-range" suffix))
((m ,type-1) (n ,type-2) startr endr startc endc)
(with-typed-mref (m ,element-type-1)
(with-typed-mref (n ,element-type-2)
@@ -111,10 +111,10 @@
(logand ,max (lognor (mref m i j) (mref n i j)))))))
m))
- (defmethod ,(ch-util:make-intern (concatenate 'string name "!" suffix))
+ (defmethod ,(make-intern (concatenate 'string name "!" suffix))
((m ,type-1) (n ,type-2))
(destructuring-bind (mr mc) (dim m)
- (,(ch-util:make-intern (concatenate 'string name "!-range" suffix)) m n 0 (1- mr) 0 (1- mc))))
+ (,(make-intern (concatenate 'string name "!-range" suffix)) m n 0 (1- mr) 0 (1- mc))))
)))))
View
@@ -5,7 +5,7 @@
(let ((element-type-1 (element-type (find-class `,type-1)))
(accumulator-element-type (element-type (find-class `,accumulator-type))))
`(progn
- (defmethod ,(ch-util:make-intern (concatenate 'string name "-range" suffix))
+ (defmethod ,(make-intern (concatenate 'string name "-range" suffix))
((m ,type-1) startr endr startc endc &key in-place)
(destructuring-bind (mr mc) (dim m)
(if in-place
@@ -32,7 +32,7 @@
(,op (mref m i j)))))))
p))))
- (defmethod ,(ch-util:make-intern (concatenate 'string name suffix))
+ (defmethod ,(make-intern (concatenate 'string name suffix))
((m ,type-1) &key in-place)
(if in-place
(with-typed-mref (m ,element-type-1)
@@ -53,7 +53,7 @@
(element-type-2 (element-type (find-class `,type-2)))
(accumulator-element-type (element-type (find-class `,accumulator-type))))
`(progn
- (defmethod ,(ch-util:make-intern (concatenate 'string name "-range" suffix))
+ (defmethod ,(make-intern (concatenate 'string name "-range" suffix))
((m ,type-1) (n ,type-2) startr endr startc endc &key in-place)
(destructuring-bind (mr mc) (dim m)
(if in-place
@@ -87,7 +87,7 @@
(,op (mref m i j) (mref n i j))))))))
p))))
- (defmethod ,(ch-util:make-intern (concatenate 'string name suffix))
+ (defmethod ,(make-intern (concatenate 'string name suffix))
((m ,type-1) (n ,type-2) &key in-place)
(if in-place
,(if allow-in-place
View
@@ -241,9 +241,18 @@
mpl)
)))
+(flet ((cca (l1 l2)
+ (dolist (x l1)
+ (let ((y (member x l2)))
+ (if y (return y))))))
+ (defun closest-common-ancestor (itm &rest lis)
+ (if (null lis)
+ itm
+ (cca itm (apply #'closest-common-ancestor lis)))))
+
(defgeneric closest-common-matrix-class (m1 &rest mr)
(:method ((m1 matrix) &rest mr)
- (car (apply #'ch-util:closest-common-ancestor
+ (car (apply #'closest-common-ancestor
(mapcar #'(lambda (x) (matrix-precedence-list (class-of x)))
(cons m1 mr))))))
@@ -456,16 +465,16 @@
(macrolet ((frob (name op)
`(progn
;;; define the row op
- (defgeneric ,(ch-util:make-intern (concatenate 'string "scalar-" name "-row"))
+ (defgeneric ,(make-intern (concatenate 'string "scalar-" name "-row"))
(a k q))
- (defmethod ,(ch-util:make-intern (concatenate 'string "scalar-" name "-row"))
+ (defmethod ,(make-intern (concatenate 'string "scalar-" name "-row"))
((a matrix) k q)
(map-row a k #'(lambda (x) (apply ,op (list x q))))
a)
;;; define the column op
- (defgeneric ,(ch-util:make-intern (concatenate 'string "scalar-" name "-col"))
+ (defgeneric ,(make-intern (concatenate 'string "scalar-" name "-col"))
(a k q))
- (defmethod ,(ch-util:make-intern (concatenate 'string "scalar-" name "-col"))
+ (defmethod ,(make-intern (concatenate 'string "scalar-" name "-col"))
((a matrix) k q)
(map-col a k #'(lambda (x) (apply ,op (list x q))))
a))))
View
@@ -406,6 +406,19 @@
(mat-scale x (/ n) :in-place t)
x)))))
+(defun median (seq)
+ (let ((v (cond ((vectorp seq) (copy-seq seq))
+ ((listp seq) (coerce seq 'vector)))))
+ (when (and v (plusp (length v)))
+ (sort v #'<)
+ (let ((f (floor (length v) 2)))
+ (cond ((oddp (length v))
+ (elt v f))
+ (t
+ (/ (+ (elt v (1- f))
+ (elt v f))
+ 2)))))))
+
(defun matrix-medians (matrices)
(cond ((null matrices) nil)
((= (length matrices) 1) (car matrices))
@@ -420,7 +433,7 @@
with l
do (push (mref m i j) l)
finally (setf (mref x i j)
- (coerce (ch-util::median l)
+ (coerce (median l)
'double-float)))))
x)))))
Oops, something went wrong.

0 comments on commit b59cbfc

Please sign in to comment.