Menu
▾
▴
[Matlisp-commit] [matlisp-git]matlisp branch tensor updated. 2012-02-23-332-g6cfc62a
|
From: Akshay S. <ak...@us...> - 2014-03-07 08:53:18
|
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "matlisp".
The branch, tensor has been updated
via 6cfc62a0b8737f16a23c7c971cd5055fefb42750 (commit)
via f3b37d1e92b7ee9cf9b508bd98df20df304bb958 (commit)
via f235ae0cca3dc81ef9fabf2a35681ffed8505c79 (commit)
via f82f9f87566e7359d0ad758dc61dc070cb29a3b0 (commit)
via 03a936712182f839eec89db4ba08f0708af98dca (commit)
via 6b070ed0049cd5271379c18e7a08e6f222d3b015 (commit)
via 749437c8bb376d094b604c6977a7e7c037a522a0 (commit)
via 8aebe561eef23310bcbb1cb2f93518a68f454231 (commit)
via 9a4472e4325ca93c9bdbddfedf28de9ee724b6cc (commit)
via ae2c399227295cf632250d8ba6b0ddeb984d0cae (commit)
via 1f0deb99d702dee0b93e3defe2404b307c7b3530 (commit)
from f38e6dde50fbe1552793f8146fa42734d522e9c9 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 6cfc62a0b8737f16a23c7c971cd5055fefb42750
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Mar 7 00:53:06 2014 -0800
Removed whitespace in compressed sparse.
diff --git a/src/base/compressed-sparse.lisp b/src/base/compressed-sparse.lisp
index 0f7db62..315a943 100644
--- a/src/base/compressed-sparse.lisp
+++ b/src/base/compressed-sparse.lisp
@@ -133,7 +133,7 @@
:do (setf (aref ni i) r
(aref vi i) v))))
(t/store-set ,clname value (store tensor) idx))
- (when (>= idx 0)
+ (when (>= idx 0)
(let ((ns (neighbour-start tensor))
(ni (neighbour-id tensor))
(vi (store tensor)))
@@ -145,5 +145,5 @@
(aref vi i) (aref vi (1+ i))))
(loop :for i :from (1+ col) :below (length ns)
:do (decf (aref ns i)))))))
- value))))
+ value))))
(setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value)))
commit f3b37d1e92b7ee9cf9b508bd98df20df304bb958
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Mar 7 00:50:40 2014 -0800
Added a ref method for compressed sparse matrices.
diff --git a/src/base/compressed-sparse.lisp b/src/base/compressed-sparse.lisp
index c4eb11e..0f7db62 100644
--- a/src/base/compressed-sparse.lisp
+++ b/src/base/compressed-sparse.lisp
@@ -30,7 +30,7 @@
(lb (aref nst col) :type index-type)
(ub (aref nst (1+ col)) :type index-type))
(declare (type index-type row col))
- (if (or (= lb ub) (< row (aref nid lb)) (> row (aref nid (1- ub)))) -1
+ (if (or (= lb ub) (< row (aref nid lb)) (> row (aref nid (1- ub)))) (values -1 row col)
(values
(very-quickly
(loop :with j := (ash (+ lb ub) -1)
@@ -87,28 +87,63 @@
(t/store-ref ,clname (store tensor) idx)))))
(apply #'ref (cons tensor subscripts))))
-;; (defmethod (setf ref) (value (tensor compressed-sparse-matrix) &rest subscripts)
-;; (let ((clname (class-name (class-of tensor))))
-;; (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
-;; (compile-and-eval
-;; `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts)
-;; (multiple-value-bind (idx row col) (compressed-sparse-indexing (if (numberp (car subscripts)) subscripts (car subscripts)) tensor)
-;; (if (< idx 0)
-;; (let ((ns (neighbour-start tensor))
-;; (ni (neighbour-id tensor))
-;; (vi (store tensor)))
-;; (unless (> (store-size tensor) (aref ns (1- (length ns))))
-;; (let ((sto-new (make-a-bigger-array)))
-;; (move-things forward)
-;; copy-back-to-vi..))
-;; (let ((row-data (merge 'list
-;; (cons row (t/coerce ,(field-type clname) value))
-;; (loop :for j :from (aref ns col) :to (aref ns (1+ col))
-;; :collect (cons (aref ni j) (aref vi j)))
-;; #'< :key #'car)))
-
-
-;; )
-;; (t/store-set ,clname (t/coerce ,(field-type clname) value) (store tensor) idx)))))
-;; (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value)))
-;;
+(defmethod (setf ref) (value (tensor compressed-sparse-matrix) &rest subscripts)
+ (let ((clname (class-name (class-of tensor))))
+ (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
+ (compile-and-eval
+ `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts)
+ (multiple-value-bind (idx row col) (compressed-sparse-indexing (if (numberp (car subscripts)) subscripts (car subscripts)) tensor)
+ (declare (type index-type idx row col))
+ (let-typed ((value (t/coerce ,(field-type clname) value) :type ,(field-type clname)))
+ (if (/= value (t/fid+ ,(field-type clname)))
+ (if (< idx 0)
+ (let* ((ns (neighbour-start tensor))
+ (value (t/coerce ,(field-type clname) value))
+ (row-data (let ((ni (neighbour-id tensor))
+ (vi (store tensor)))
+ (merge 'list
+ (list (cons row value))
+ (loop :for j :from (aref ns col) :below (aref ns (1+ col))
+ :collect (cons (aref ni j) (aref vi j)))
+ #'< :key #'car))))
+ (unless (> (store-size tensor) (aref ns (1- (length ns))))
+ (destructuring-bind (ni vi) (t/store-allocator ,clname (dims tensor) (+ (store-size tensor) *default-sparse-store-increment*))
+ (let ((nio (neighbour-id tensor))
+ (vio (store tensor)))
+ (very-quickly
+ (declare (type index-store-vector nio ni ns)
+ (type ,(store-type clname) vio vi))
+ (loop :for i :from 0 :below (aref ns col)
+ :do (setf (aref nio i) (aref ni i)
+ (aref vio i) (aref vi i)))
+ (loop :for i :from (aref ns (1+ col)) :below (aref ns (1- (length ns)))
+ :do (setf (aref nio (1+ i)) (aref ni i)
+ (aref vio (1+ i)) (aref vi i))))
+ (setf (slot-value tensor 'neighbour-id) ni
+ (slot-value tensor 'store) vi))))
+ (let ((ni (neighbour-id tensor))
+ (vi (store tensor)))
+ (very-quickly
+ (declare (type index-store-vector ni ns)
+ (type ,(store-type clname) vi))
+ (loop :for i :from (1+ col) :below (length ns)
+ :do (incf (aref ns i))))
+ (loop :for (r . v) :in row-data
+ :for i := (aref ns col) :then (1+ i)
+ :do (setf (aref ni i) r
+ (aref vi i) v))))
+ (t/store-set ,clname value (store tensor) idx))
+ (when (>= idx 0)
+ (let ((ns (neighbour-start tensor))
+ (ni (neighbour-id tensor))
+ (vi (store tensor)))
+ (very-quickly
+ (declare (type index-store-vector ns ni)
+ (type ,(store-type clname) vi))
+ (loop :for i :from idx :below (aref ns (1- (length ns)))
+ :do (setf (aref ni i) (aref ni (1+ i))
+ (aref vi i) (aref vi (1+ i))))
+ (loop :for i :from (1+ col) :below (length ns)
+ :do (decf (aref ns i)))))))
+ value))))
+ (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value)))
diff --git a/src/base/coordinate-sparse.lisp b/src/base/coordinate-sparse.lisp
index af77ead..6f4b7f2 100644
--- a/src/base/coordinate-sparse.lisp
+++ b/src/base/coordinate-sparse.lisp
@@ -1,9 +1,6 @@
(in-package :matlisp)
;;One may to do better than a Hash-table for this.
-(defparameter *default-sparsity* 1/1000)
-(defparameter *max-sparse-size* 10000)
-
(defclass coordinate-sparse-tensor (sparse-tensor)
((strides :initarg :strides :reader strides :type index-store-vector
:documentation "Strides for accesing elements of the tensor.")))
diff --git a/src/base/tweakable.lisp b/src/base/tweakable.lisp
index cab998f..32918db 100644
--- a/src/base/tweakable.lisp
+++ b/src/base/tweakable.lisp
@@ -6,6 +6,21 @@
;;that you use lexical scoping to affect local changes to
;;code (global variables are only bad if you overwrite them :)
+(defparameter *default-sparse-store-increment* 100
+ "
+ Determines the increment by which the store of a compressed sparse matrix is increased,
+ when it runs out of store.")
+
+(defparameter *default-sparsity* 1/1000
+ "
+ Determines the default sparsity for a newly created sparse matrix, when the number of non-zero is
+ not specified.")
+
+(defparameter *max-sparse-size* 10000
+ "
+ Upper bounds the store size for a newly created sparse matrix, when the number of non-zero is
+ not specified.")
+
;;Default ordering of strides
(defparameter *default-stride-ordering* :col-major
"
commit f235ae0cca3dc81ef9fabf2a35681ffed8505c79
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Mar 6 22:43:58 2014 -0800
Added "ignorable" declarations to deft/method; gets rid of all those annoying style warnings.
diff --git a/src/utilities/template.lisp b/src/utilities/template.lisp
index 4f40e41..d802043 100644
--- a/src/utilities/template.lisp
+++ b/src/utilities/template.lisp
@@ -115,12 +115,17 @@
(error "Undefined template : ~a~%" ',name)))
(,meth-sym (getf ,data-sym :methods))
(,afun-sym (lambda (,(if single? disp-vars disp-sym) ,@args)
- ,(recursive-append
+ (declare (ignorable ,@(remove-if #'(lambda (x) (char= #\& (aref (symbol-name x) 0)))
+ (mapcar #'(lambda (x) (if (consp x) (car x) x))
+ (cons (if single? disp-vars disp-sym) args)))))
+ ,(recursive-append
(unless single?
- `(destructuring-bind (,@disp-vars) ,disp-sym))
+ `(destructuring-bind (,@disp-vars) ,disp-sym
+ (declare (ignorable ,@disp-vars))))
`(progn
,@body))))
(,sort-sym (getf ,data-sym :sorter)))
+ (declare (ignorable ,data-sym ,meth-sym ,afun-sym ,sort-sym))
(setf ,meth-sym (topological-sort (setadd ,meth-sym (list ,afun-sym ',disp-spls) #'(lambda (a b) (list-eq (second a) (second b)))) #'(lambda (a b) (funcall ,sort-sym (second a) (second b)))))
(setf (getf ,data-sym :methods) ,meth-sym)
,afun-sym)))))
commit f82f9f87566e7359d0ad758dc61dc070cb29a3b0
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Mar 6 22:14:19 2014 -0800
Switched from vanilla sort to topological sort to deal with the lack of total ordering on types.
diff --git a/src/blas/copy.lisp b/src/blas/copy.lisp
index 146e1b6..7b3a189 100644
--- a/src/blas/copy.lisp
+++ b/src/blas/copy.lisp
@@ -124,7 +124,7 @@
(assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil
'tensor-dimension-mismatch))
-(defmethod :before copy! ((a sparse-tensor) (b sparse-tensor))
+(defmethod copy! :before ((a base-tensor) (b compressed-sparse-matrix))
(assert (< (store-size a) (store-size b)) nil 'tensor-insufficient-store))
(defmethod copy! ((x standard-tensor) (y standard-tensor))
diff --git a/src/utilities/template.lisp b/src/utilities/template.lisp
index f11fe68..4f40e41 100644
--- a/src/utilities/template.lisp
+++ b/src/utilities/template.lisp
@@ -6,6 +6,37 @@
(defvar *template-table* (make-hash-table))
+(defun topological-sort (lst func &optional (test #'eql))
+ (multiple-value-bind (nlst len) (loop :for ele :in lst
+ :for i := 0 :then (1+ i)
+ :collect (cons i ele) :into ret
+ :finally (return (values ret (1+ i))))
+ (let* ((S nil)
+ (graph (let ((ret (make-array len)))
+ (loop :for (i . ele) :in nlst
+ :do (let ((children (mapcar #'car (remove-if-not #'(lambda (x) (and (not (funcall test (cdr x) ele)) (funcall func (cdr x) ele))) nlst)))
+ (parents (mapcar #'car (remove-if-not #'(lambda (x) (and (not (funcall test (cdr x) ele)) (funcall func ele (cdr x)))) nlst))))
+ (when (null parents)
+ (push i S))
+ (setf (aref ret i) (list ele children parents))))
+ ret))
+ (ordering nil))
+ (let ((last-S (last S)))
+ (do ((slst S (cdr slst)))
+ ((null slst))
+ (let* ((i (car slst))
+ (children (second (aref graph i))))
+ (mapcar #'(lambda (x)
+ (let ((par (third (aref graph x))))
+ (let ((par (remove i par)))
+ (setf (third (aref graph x)) par)
+ (when (null par)
+ (setf (cdr last-S) (cons x nil)
+ last-S (cdr last-S))))))
+ children)
+ (push i ordering))))
+ (mapcar #'(lambda (x) (car (aref graph x))) ordering))))
+
(defun match-lambda-lists (lsta lstb)
(let ((optional? nil))
(labels ((optp? (a b)
@@ -90,7 +121,7 @@
`(progn
,@body))))
(,sort-sym (getf ,data-sym :sorter)))
- (setf ,meth-sym (sort (setadd ,meth-sym (list ,afun-sym ',disp-spls) #'(lambda (a b) (list-eq (second a) (second b)))) #'(lambda (a b) (funcall ,sort-sym (second a) (second b)))))
+ (setf ,meth-sym (topological-sort (setadd ,meth-sym (list ,afun-sym ',disp-spls) #'(lambda (a b) (list-eq (second a) (second b)))) #'(lambda (a b) (funcall ,sort-sym (second a) (second b)))))
(setf (getf ,data-sym :methods) ,meth-sym)
,afun-sym)))))
commit 03a936712182f839eec89db4ba08f0708af98dca
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Mar 4 02:13:21 2014 -0800
Saving state on the sparse tensor.
diff --git a/matlisp.asd b/matlisp.asd
index a356b04..92f4b31 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -126,12 +126,15 @@
(:file "blas-helpers"
:depends-on ("standard-tensor" "permutation"))
(:file "print"
- :depends-on ("standard-tensor"))))
+ :depends-on ("base-tensor" "standard-tensor"))
+ (:file "coordinate-sparse")
+ (:file "compressed-sparse")))
(:module "matlisp-classes"
:pathname "classes"
:depends-on ("matlisp-base")
:components ((:file "numeric")
+ (:file "sparse")
#+maxima
(:file "symbolic-tensor")
(:file "matrix"
diff --git a/src/base/compressed-sparse.lisp b/src/base/compressed-sparse.lisp
index 85b65d3..c4eb11e 100644
--- a/src/base/compressed-sparse.lisp
+++ b/src/base/compressed-sparse.lisp
@@ -24,41 +24,41 @@
(setf row (the index-type (aref subs 0))
col (the index-type (aref subs 1)))))
(when (transpose? tensor)
- (rotatef row col))
- (let*-typed ((nst (neighbour-start tensor) :type index-store-vector)
- (nid (neighbour-id tensor) :type index-store-vector)
- (lb (aref nst col) :type index-type)
- (ub (aref nst (1+ col)) :type index-type))
+ (rotatef row col))
+ (let*-typed ((nst (neighbour-start tensor) :type index-store-vector)
+ (nid (neighbour-id tensor) :type index-store-vector)
+ (lb (aref nst col) :type index-type)
+ (ub (aref nst (1+ col)) :type index-type))
(declare (type index-type row col))
(if (or (= lb ub) (< row (aref nid lb)) (> row (aref nid (1- ub)))) -1
- (very-quickly
- (loop :with j := (ash (+ lb ub) -1)
- :repeat 64
- :do (progn
- #+nil(format t "~a, ~a, ~a~%" lb j ub)
- (cond
- ((= (aref nid j) row) (return j))
- ((>= lb (1- ub)) (return -1))
- (t
- (if (< row (aref nid j))
- (setf ub j)
- (setf lb (1+ j)))
- (setf j (ash (+ lb ub) -1)))))))))))
-
-(deft/method t/store-allocator (sym compressed-sparse-matrix) (size &optional initial-element)
- (let ((sto-type (store-element-type sym)))
- (using-gensyms (decl (size))
- `(let (,@decl)
- (destructuring-bind (ni nz) (t/compute-store-size ,sym ,size)
- (list
- (allocate-index-store (1+ ni))
- (allocate-index-store nz)
- (make-array nz :element-type ',sto-type :initial-element ,(if (subtypep sto-type 'number) `(t/fid+ ,sto-type) nil))))))))
+ (values
+ (very-quickly
+ (loop :with j := (ash (+ lb ub) -1)
+ :repeat 64
+ :do (progn
+ #+nil(format t "~a, ~a, ~a~%" lb j ub)
+ (cond
+ ((= (aref nid j) row) (return j))
+ ((>= lb (1- ub)) (return -1))
+ (t
+ (if (< row (aref nid j))
+ (setf ub j)
+ (setf lb (1+ j)))
+ (setf j (ash (+ lb ub) -1)))))))
+ row col)))))
+
+;;Templates
+(deft/method t/store-allocator (cl compressed-sparse-matrix) (size &optional nz)
+ (let ((sto-type (store-element-type cl)))
+ `(destructuring-bind (nr nc) ,size
+ (let ((nz (or ,nz (min (ceiling (* nr nc *default-sparsity*)) *max-sparse-size*))))
+ (list
+ (allocate-index-store nz)
+ (make-array (t/compute-store-size ,cl nz) :element-type ',sto-type :initial-element ,(if (subtypep sto-type 'number) `(t/fid+ ,sto-type) nil)))))))
(deft/method t/compute-store-size (sym compressed-sparse-matrix) (size)
- `(destructuring-bind (nr nc &optional nz) ,size
- (list nc (or nz (min (ceiling (* nr nc *default-sparsity*)) *max-sparse-size*)))))
-
+ size)
+;;
(deft/method t/store-type (sym compressed-sparse-matrix) (&optional (size '*))
`(simple-array ,(store-element-type sym) (,size)))
@@ -66,122 +66,49 @@
(assert (null (cdr idx)) nil "given more than one index for compressed-store")
`(aref (the ,(store-type sym) ,store) (the index-type ,(car idx))))
-(deft/method t/store-size (sym compressed-sparse-matrix) (ele)
- `(length ,ele))
-
-(deft/method t/store-element-type (sym compressed-sparse-matrix) ()
- (macroexpand `(t/field-type ,sym)))
-
-;;
(deft/method t/store-set (sym compressed-sparse-matrix) (value store &rest idx)
(assert (null (cdr idx)) nil "given more than one index for compressed store")
`(setf (aref (the ,(store-type sym) ,store) (the index-type ,(car idx))) (the ,(field-type sym) ,value)))
-;; (deft/method t/store-set (sym coordinate-sparse-tensor) (value store &rest idx)
-;; (assert (null (cdr idx)) nil "given more than one index for hashtable.")
-;; (with-gensyms (val)
-;; `(let-typed ((,val ,value :type ,(field-type sym)))
-;; (unless (t/f= ,(field-type sym) ,val (t/fid+ ,(field-type sym)))
-;; (setf (gethash ,(car idx) ,store) (the ,(field-type sym) ,value))))))
+(deft/method t/store-size (sym compressed-sparse-matrix) (ele)
+ `(length ,ele))
+(deft/method t/store-element-type (sym compressed-sparse-matrix) ()
+ (macroexpand `(t/field-type ,sym)))
;;
(defmethod ref ((tensor compressed-sparse-matrix) &rest subscripts)
(let ((clname (class-name (class-of tensor))))
(assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
(compile-and-eval
- `(defmethod ref ((tensor ,clname) &rest subscripts)
+ `(defmethod ref ((tensor ,clname) &rest subscripts)
(let ((idx (compressed-sparse-indexing (if (numberp (car subscripts)) subscripts (car subscripts)) tensor)))
(if (< idx 0)
(t/sparse-fill ,clname)
(t/store-ref ,clname (store tensor) idx)))))
(apply #'ref (cons tensor subscripts))))
-#+nil
-(defmethod (setf ref) (value (tensor compressed-sparse-matrix) &rest subscripts)
- (let ((clname (class-name (class-of tensor))))
- (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
- (compile-and-eval
- `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts)
- (let* ((subs (if (numberp (car subscripts)) subscripts (car subscripts)))
- (idx (store-indexing subs tensor))
- (sto (store tensor)))
- (t/store-set ,clname (t/coerce ,(field-type clname) value) sto idx)
- (t/store-ref ,clname sto idx))))
- (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value)))
-;;
-(defleaf real-compressed-sparse-matrix (compressed-sparse-matrix) ())
-(deft/method t/field-type (sym real-compressed-sparse-matrix) ()
- 'double-float)
-
+;; (defmethod (setf ref) (value (tensor compressed-sparse-matrix) &rest subscripts)
+;; (let ((clname (class-name (class-of tensor))))
+;; (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
+;; (compile-and-eval
+;; `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts)
+;; (multiple-value-bind (idx row col) (compressed-sparse-indexing (if (numberp (car subscripts)) subscripts (car subscripts)) tensor)
+;; (if (< idx 0)
+;; (let ((ns (neighbour-start tensor))
+;; (ni (neighbour-id tensor))
+;; (vi (store tensor)))
+;; (unless (> (store-size tensor) (aref ns (1- (length ns))))
+;; (let ((sto-new (make-a-bigger-array)))
+;; (move-things forward)
+;; copy-back-to-vi..))
+;; (let ((row-data (merge 'list
+;; (cons row (t/coerce ,(field-type clname) value))
+;; (loop :for j :from (aref ns col) :to (aref ns (1+ col))
+;; :collect (cons (aref ni j) (aref vi j)))
+;; #'< :key #'car)))
+
+
+;; )
+;; (t/store-set ,clname (t/coerce ,(field-type clname) value) (store tensor) idx)))))
+;; (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value)))
;;
-(defmethod :before copy! ((a sparse-tensor) (b sparse-tensor))
- (assert (< (store-size a) (store-size b)) nil 'tensor-insufficient-store))
-
-(deft/method t/zeros (class compressed-sparse-matrix) (dims &optional nz)
- `(destructuring-bind (vi vr vd) (t/store-allocator ,class (append ,dims ,@(when nz `((list ,nz)))))
- (make-instance ',class
- :dimensions (make-index-store ,dims)
- :neighbour-start vi
- :neighbour-id vr
- :store vd)))
-
-(defmethod copy! ((x coordinate-sparse-tensor) (y compressed-sparse-matrix))
- (let ((clx (class-name (class-of x)))
- (cly (class-name (class-of y))))
- (assert (and (member clx *tensor-type-leaves*)
- (member cly *tensor-type-leaves*))
- nil 'tensor-abstract-class :tensor-class (list clx cly))
- (compile-and-eval
- `(defmethod copy! ((x ,clx) (y ,cly))
- (let-typed ((stds (strides x) :type index-store-vector))
- (assert (and (tensor-matrixp x) (= (aref stds 0) 1)) nil 'tensor-invalid-stride-value)
- (let ((col-stride (aref stds 1))
- (row-data (make-array (ncols x) :initial-element nil)))
- (very-quickly
- (loop :for key :being :the :hash-keys :of (store x)
- :using (hash-value value)
- :do (multiple-value-bind (c r) (floor (the index-type key) col-stride)
- (push (cons r value) (aref row-data c)))))
- (let-typed ((vi (neighbour-start y) :type index-store-vector)
- (vr (neighbour-id y) :type index-store-vector)
- (vd (store y) :type ,(store-type cly)))
- (setf (aref vi 0) 0)
- (very-quickly
- (loop :for i :from 0 :below (ncols x)
- :with col-stop := 0
- :do (let ((rowd (sort (aref row-data i) #'(lambda (x y) (< (the index-type x) (the index-type y))) :key #'car)))
- (loop :for (r . v) :in rowd
- :do (locally
- (declare (type ,(field-type clx) v))
- (setf (aref vr col-stop) r)
- (t/store-set real-compressed-sparse-matrix (t/coerce ,(field-type cly) v) vd col-stop)
- (incf col-stop)))
- (setf (aref vi (1+ i)) col-stop)))))
- y))))
- (copy! x y)))
-
-(defmethod copy-generic ((a sparse-tensor) (type (eql 'real-compressed-sparse-matrix)))
- (let-typed ((stds (strides a) :type index-store-vector))
- (assert (and (tensor-matrixp a) (= (aref stds 0) 1)) nil 'tensor-not-matrix)
- (let ((col-stride (aref stds 1))
- (row-data (make-array (ncols a) :initial-element nil)))
- (loop :for key :being :the :hash-keys :of (store a)
- :using (hash-value value)
- :do (multiple-value-bind (c r) (floor key col-stride)
- (push (cons r value) (aref row-data c))))
- (destructuring-bind (vi vr vd) (t/store-allocator real-compressed-sparse-matrix (append (dims a) (list (store-size a))))
- (setf (aref vi 0) 0)
- (loop :for i :from 0 :below (ncols a)
- :with col-stop := 0
- :do (let ((rowd (sort (aref row-data i) #'< :key #'car)))
- (loop :for (r . v) :in rowd
- :do (progn
- (setf (aref vr col-stop) r
- (aref vd col-stop) v)
- (incf col-stop)))
- (setf (aref vi (1+ i)) col-stop)))
- (make-instance 'real-compressed-sparse-matrix
- :dimensions (copy-seq (dimensions a))
- :neighbour-start vi
- :neighbour-id vr
- :store vd)))))
diff --git a/src/base/coordinate-sparse.lisp b/src/base/coordinate-sparse.lisp
index 2365eb0..af77ead 100644
--- a/src/base/coordinate-sparse.lisp
+++ b/src/base/coordinate-sparse.lisp
@@ -12,9 +12,9 @@
(deft/method t/sparse-fill (sym sparse-tensor) ()
`(t/fid+ (t/field-type ,sym)))
-(deft/method t/store-allocator (sym coordinate-sparse-tensor) (size &optional initial-element)
+(deft/method t/store-allocator (sym coordinate-sparse-tensor) (size &optional nz)
(with-gensyms (size-sym)
- `(let ((,size-sym (t/compute-store-size ,sym ,size)))
+ `(let ((,size-sym (or ,nz (min (max sb-impl::+min-hash-table-size+ (ceiling (/ ,size *default-sparsity*))) *max-sparse-size*))))
(make-hash-table :size ,size-sym))))
(deft/method t/store-ref (sym coordinate-sparse-tensor) (store &rest idx)
@@ -37,16 +37,8 @@
(deft/method t/store-type (sym coordinate-sparse-tensor) (&optional (size '*))
'hash-table)
-(deft/method t/compute-store-size (sym coordinate-sparse-tensor) (size)
- `(max (min sb-impl::+min-hash-table-size+ (ceiling (/ ,size *default-sparsity*))) *max-sparse-size*))
-
(defmethod head ((tensor coordinate-sparse-tensor))
0)
-;firefox;
-(defleaf real-coordinate-sparse-tensor (coordinate-sparse-tensor) ())
-
-(deft/method t/field-type (sym real-coordinate-sparse-tensor) ()
- 'double-float)
;;
(defmethod ref ((tensor coordinate-sparse-tensor) &rest subscripts)
(let ((clname (class-name (class-of tensor))))
@@ -69,14 +61,3 @@
(t/store-ref ,clname sto idx))))
(setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value)))
;;
-
-(deft/method t/zeros (class coordinate-sparse-tensor) (dims &optional initial-element)
- (with-gensyms (astrs adims sizs)
- `(let* ((,adims (make-index-store ,dims)))
- (declare (type index-store-vector ,adims))
- (multiple-value-bind (,astrs ,sizs) (make-stride-cmj ,adims)
- (declare (type index-store-vector ,astrs))
- (make-instance ',class
- :dimensions ,adims
- :strides ,astrs
- :store (t/store-allocator ,class ,sizs))))))
diff --git a/src/base/sparse-tensor.lisp b/src/base/sparse-tensor.lisp
deleted file mode 100644
index e69de29..0000000
diff --git a/src/blas/copy.lisp b/src/blas/copy.lisp
index af584dd..146e1b6 100644
--- a/src/blas/copy.lisp
+++ b/src/blas/copy.lisp
@@ -124,6 +124,9 @@
(assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil
'tensor-dimension-mismatch))
+(defmethod :before copy! ((a sparse-tensor) (b sparse-tensor))
+ (assert (< (store-size a) (store-size b)) nil 'tensor-insufficient-store))
+
(defmethod copy! ((x standard-tensor) (y standard-tensor))
(let ((clx (class-name (class-of x)))
(cly (class-name (class-of y))))
@@ -149,6 +152,41 @@
(error "Don't know how to copy from ~a to ~a" clx cly))))
(copy! x y))
+(defmethod copy! ((x coordinate-sparse-tensor) (y compressed-sparse-matrix))
+ (let ((clx (class-name (class-of x)))
+ (cly (class-name (class-of y))))
+ (assert (and (member clx *tensor-type-leaves*)
+ (member cly *tensor-type-leaves*))
+ nil 'tensor-abstract-class :tensor-class (list clx cly))
+ (compile-and-eval
+ `(defmethod copy! ((x ,clx) (y ,cly))
+ (let-typed ((stds (strides x) :type index-store-vector))
+ (assert (and (tensor-matrixp x) (= (aref stds 0) 1)) nil 'tensor-invalid-stride-value)
+ (let ((col-stride (aref stds 1))
+ (row-data (make-array (ncols x) :initial-element nil)))
+ (very-quickly
+ (loop :for key :being :the :hash-keys :of (store x)
+ :using (hash-value value)
+ :do (multiple-value-bind (c r) (floor (the index-type key) col-stride)
+ (push (cons r value) (aref row-data c)))))
+ (let-typed ((vi (neighbour-start y) :type index-store-vector)
+ (vr (neighbour-id y) :type index-store-vector)
+ (vd (store y) :type ,(store-type cly)))
+ (setf (aref vi 0) 0)
+ (very-quickly
+ (loop :for i :from 0 :below (ncols x)
+ :with col-stop := 0
+ :do (let ((rowd (sort (aref row-data i) #'(lambda (x y) (< (the index-type x) (the index-type y))) :key #'car)))
+ (loop :for (r . v) :in rowd
+ :do (locally
+ (declare (type ,(field-type clx) v))
+ (setf (aref vr col-stop) r)
+ (t/store-set real-compressed-sparse-matrix (t/coerce ,(field-type cly) v) vd col-stop)
+ (incf col-stop)))
+ (setf (aref vi (1+ i)) col-stop)))))
+ y))))
+ (copy! x y)))
+
(defmethod copy! ((x t) (y standard-tensor))
(let ((cly (class-name (class-of y))))
(assert (and (member cly *tensor-type-leaves*))
@@ -178,4 +216,10 @@
((or (not type) (subtypep type 'standard-tensor))
(let ((ret (zeros (dimensions tensor) (or type (class-of tensor)))))
(copy! tensor ret)))))
-
+
+(defmethod copy-generic ((tensor sparse-tensor) type)
+ (cond
+ ((or (not type) (subtypep type 'sparse-tensor))
+ (let ((ret (zeros (dimensions tensor) (or type (class-of tensor)) (store-size tensor))))
+ (copy! tensor ret)))))
+
diff --git a/src/blas/maker.lisp b/src/blas/maker.lisp
index cffe047..797b623 100644
--- a/src/blas/maker.lisp
+++ b/src/blas/maker.lisp
@@ -13,9 +13,32 @@
:strides ,astrs
:store (t/store-allocator ,class ,sizs ,@(when initial-element `((t/coerce ,(field-type class) ,initial-element)))))))))
+(deft/method t/zeros (class coordinate-sparse-tensor) (dims &optional nz)
+ (with-gensyms (astrs adims sizs)
+ `(let* ((,adims (make-index-store ,dims)))
+ (declare (type index-store-vector ,adims))
+ (multiple-value-bind (,astrs ,sizs) (make-stride-cmj ,adims)
+ (declare (type index-store-vector ,astrs))
+ (make-instance ',class
+ :dimensions ,adims
+ :strides ,astrs
+ :store (t/store-allocator ,class ,sizs ,nz))))))
+
+(deft/method t/zeros (class compressed-sparse-matrix) (dims &optional nz)
+ (with-gensyms (dsym)
+ `(let ((,dsym ,dims))
+ (destructuring-bind (vr vd) (t/store-allocator ,class ,dsym ,nz)
+ (make-instance ',class
+ :dimensions (make-index-store ,dims)
+ :neighbour-start (allocate-index-store (1+ (second ,dsym)))
+ :neighbour-id vr
+ :store vd)))))
+
;;
(defgeneric zeros-generic (dims dtype &optional initial-element)
- (:documentation "A generic version of @func{zeros}.")
+ (:documentation "
+ A generic version of @func{zeros}.
+")
(:method ((dims cons) (dtype t) &optional initial-element)
;; (assert (member dtype *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class dtype)
(compile-and-eval
@@ -26,29 +49,30 @@
(zeros-generic dims dtype initial-element)))
(definline zeros (dims &optional (type *default-tensor-type*) initial-element)
- "
-Create a tensor with dimensions @arg{dims} of class @arg{dtype}.
-The optional argument @arg{initial-element} is used in two completely
-incompatible ways.
-
-If @arg{dtype} is a dense tensor, then @arg{initial-element}, is used to
-initialize all the elements. If @arg{dtype} is however, a sparse tensor,
-it is used for computing the number of nonzeros slots in the store.
-
-Example:
-> (zeros 3)
-#<REAL-TENSOR #(3)
- 0.0000 0.0000 0.0000
->
-
-> (zeros 3 'complex-tensor 2)
-#<COMPLEX-TENSOR #(3)
- 2.0000 2.0000 2.0000
->
-
-> (zeros '(10000 10000) 'real-compressed-sparse-matrix 10000)
-#<REAL-COMPRESSED-SPARSE-MATRIX #(10000 10000), store-size: 10000>
-" (let ((*check-after-initializing?* nil))
+"
+ Create a tensor with dimensions @arg{dims} of class @arg{dtype}.
+ The optional argument @arg{initial-element} is used in two completely
+ incompatible ways.
+
+ If @arg{dtype} is a dense tensor, then @arg{initial-element}, is used to
+ initialize all the elements. If @arg{dtype} is however, a sparse tensor,
+ it is used for computing the number of nonzeros slots in the store.
+
+ Example:
+ > (zeros 3)
+ #<REAL-TENSOR #(3)
+ 0.0000 0.0000 0.0000
+ >
+
+ > (zeros 3 'complex-tensor 2)
+ #<COMPLEX-TENSOR #(3)
+ 2.0000 2.0000 2.0000
+ >
+
+ > (zeros '(10000 10000) 'real-compressed-sparse-matrix 10000)
+ #<REAL-COMPRESSED-SPARSE-MATRIX #(10000 10000), store-size: 10000>
+"
+ (let ((*check-after-initializing?* nil))
(let ((type (etypecase type (standard-class (class-name type)) (symbol type))))
(etypecase dims
(vector
@@ -57,4 +81,3 @@ Example:
(zeros-generic dims type initial-element))
(fixnum
(zeros-generic (list dims) type initial-element))))))
-;;
diff --git a/src/special/map.lisp b/src/special/map.lisp
index 272aea9..e84beb5 100644
--- a/src/special/map.lisp
+++ b/src/special/map.lisp
@@ -1,19 +1,29 @@
(in-package #:matlisp)
(defgeneric mapsor! (func x y)
- (:documentation "
- Syntax
- ======
- (MAPSOR! func x y)
+ (:documentation
+"
+ Syntax
+ ======
+ (MAPSOR! func x y)
- Purpose
- =======
- Applies the function element-wise on x, and sets the corresponding
- elements in y to the value returned by the function.
+ Purpose
+ =======
+ Applies the function element-wise on x, and sets the corresponding
+ elements in y to the value returned by the function.
- Example
- =======
- > (mapsor! #'sin (randn '(2 2)) (zeros '(2 2)))
+ Example
+ =======
+ > (mapsor! #'(lambda (idx x y)
+ (if (= (car idx) (cadr idx))
+ (sin x)
+ y))
+ (randn '(2 2)) (zeros '(2 2)))
+ #<REAL-TENSOR #(2 2)
+ -9.78972E-2 0.0000
+ 0.0000 -.39243
+ >
+ >
")
(:method :before ((func function) (x standard-tensor) (y standard-tensor))
(assert (very-quickly (lvec-eq (dimensions x) (dimensions y))) nil 'tensor-dimension-mismatch)))
@@ -27,23 +37,38 @@
nil 'tensor-abstract-class :tensor-class (list clx cly))
(compile-and-eval
`(defmethod mapsor! ((func function) (x ,clx) (y ,cly))
- (let ((sto-x (store x))
- (sto-y (store y))
- (idxlst (make-list (order x))))
- (declare (type ,(store-type clx) sto-x)
- (type ,(store-type cly) sto-y))
- (very-quickly
- (mod-dotimes (idx (dimensions x))
- :with (linear-sums
- (of-x (strides x))
- (of-y (strides y)))
- :do (t/store-set ,cly (funcall func (lvec->list! idx idxlst) (t/store-ref ,clx sto-x of-x) (t/store-ref ,cly sto-y of-y)) sto-y of-y))))
+ (let-typed ((sto-x (store x) :type ,(store-type clx))
+ (sto-y (store y) :type ,(store-type cly)))
+ (mod-dotimes (idx (dimensions x))
+ :with (linear-sums
+ (of-x (strides x) (head x))
+ (of-y (strides y) (head y)))
+ :do (t/store-set ,cly (funcall func (lvec->list idx) (t/store-ref ,clx sto-x of-x) (t/store-ref ,cly sto-y of-y)) sto-y of-y)))
y)))
(mapsor! func x y))
-(definline mapsor (func x)
- (let ((ret (zeros (dimensions x) (class-of x))))
- (mapsor! func x ret)))
+(defmethod mapsor! ((func function) (x standard-tensor) (y standard-tensor))
+ (let ((clx (class-name (class-of x)))
+ (cly (class-name (class-of y))))
+ (assert (and
+ (member clx *tensor-type-leaves*)
+ (member cly *tensor-type-leaves*))
+ nil 'tensor-abstract-class :tensor-class (list clx cly))
+ (compile-and-eval
+ `(defmethod mapsor! ((func function) (x ,clx) (y ,cly))
+ (let-typed ((sto-x (store x) :type ,(store-type clx))
+ (sto-y (store y) :type ,(store-type cly)))
+ (mod-dotimes (idx (dimensions x))
+ :with (linear-sums
+ (of-x (strides x) (head x))
+ (of-y (strides y) (head y)))
+ :do (t/store-set ,cly (funcall func (lvec->list idx) (t/store-ref ,clx sto-x of-x) (t/store-ref ,cly sto-y of-y)) sto-y of-y)))
+ y)))
+ (mapsor! func x y))
+
+(definline mapsor (func x &optional output-type)
+ (let ((ret (zeros (dimensions x) (or output-type (class-of x)))))
+ (mapsor! #'(lambda (idx x y) (declare (ignore y)) (funcall func idx x)) x ret)))
;;
(defun mapslice (func x &optional (axis 0))
commit 6b070ed0049cd5271379c18e7a08e6f222d3b015
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Mar 1 14:20:34 2014 -0800
Added a proper shuffler.
diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp
index 189024d..1063ed1 100644
--- a/src/base/permutation.lisp
+++ b/src/base/permutation.lisp
@@ -31,11 +31,23 @@
(definline pidxv (&rest contents)
(make-array (length contents) :element-type 'pindex-type :initial-contents contents))
-;;Write a uniform randomiser
-(defun seqrnd (seq)
+(defun pick-random (k n)
+ (let ((ret nil)
+ (perm (allocate-pindex-store k)))
+ (loop :for i :from 0 :below k
+ :do (let ((sd (random (- n i))))
+ (loop :for ele :in ret
+ :do (if (> ele sd) (return) (incf sd)))
+ (setf (aref perm i) sd)
+ (setf ret (merge 'list (list sd) ret #'<))))
+ (values ret perm)))
+
+(defun shuffle (seq)
"Randomize the elements of a sequence. Destructive on SEQ."
- (sort seq #'> :key #'(lambda (x) (declare (ignore x))
- (random 1.0))))
+ (let* ((len (length seq))
+ (perm (nth-value 1 (pick-random len len))))
+ (apply-action! seq perm)))
+#+nil(sort seq #'> :key #'(lambda (x) (declare (ignore x)) (random 1.0)))
;;Class definitions----------------------------------------------;;
(defclass permutation ()
commit 749437c8bb376d094b604c6977a7e7c037a522a0
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Mar 1 13:01:36 2014 -0800
Saving state on Sparse tensors.
diff --git a/src/base/compressed-sparse.lisp b/src/base/compressed-sparse.lisp
new file mode 100644
index 0000000..85b65d3
--- /dev/null
+++ b/src/base/compressed-sparse.lisp
@@ -0,0 +1,187 @@
+(in-package #:matlisp)
+
+;;
+(defclass compressed-sparse-matrix (sparse-tensor)
+ ((transpose? :initform nil :initarg :transpose? :reader transpose? :type boolean
+ :documentation "If NIL the matrix is in CSC, else if T, then matrix is CSR.")
+ (neighbour-start :initarg :neighbour-start :reader neighbour-start :type index-store-vector
+ :documentation "Start index for ids and store.")
+ (neighbour-id :initarg :neighbour-id :reader neighbour-id :type index-store-vector
+ :documentation "Row id.")))
+
+(defun compressed-sparse-indexing (subs tensor)
+ (declare (type compressed-sparse-matrix tensor)
+ (type (or index-store-vector cons) subs))
+ (let-typed ((row 0 :type index-type)
+ (col 0 :type index-type))
+ (etypecase subs
+ (cons
+ (assert (null (cddr subs)) nil 'tensor-index-rank-mismatch)
+ (setf row (the index-type (car subs))
+ col (the index-type (cadr subs))))
+ (index-store-vector
+ (assert (= (length subs) 2) nil 'tensor-index-rank-mismatch)
+ (setf row (the index-type (aref subs 0))
+ col (the index-type (aref subs 1)))))
+ (when (transpose? tensor)
+ (rotatef row col))
+ (let*-typed ((nst (neighbour-start tensor) :type index-store-vector)
+ (nid (neighbour-id tensor) :type index-store-vector)
+ (lb (aref nst col) :type index-type)
+ (ub (aref nst (1+ col)) :type index-type))
+ (declare (type index-type row col))
+ (if (or (= lb ub) (< row (aref nid lb)) (> row (aref nid (1- ub)))) -1
+ (very-quickly
+ (loop :with j := (ash (+ lb ub) -1)
+ :repeat 64
+ :do (progn
+ #+nil(format t "~a, ~a, ~a~%" lb j ub)
+ (cond
+ ((= (aref nid j) row) (return j))
+ ((>= lb (1- ub)) (return -1))
+ (t
+ (if (< row (aref nid j))
+ (setf ub j)
+ (setf lb (1+ j)))
+ (setf j (ash (+ lb ub) -1)))))))))))
+
+(deft/method t/store-allocator (sym compressed-sparse-matrix) (size &optional initial-element)
+ (let ((sto-type (store-element-type sym)))
+ (using-gensyms (decl (size))
+ `(let (,@decl)
+ (destructuring-bind (ni nz) (t/compute-store-size ,sym ,size)
+ (list
+ (allocate-index-store (1+ ni))
+ (allocate-index-store nz)
+ (make-array nz :element-type ',sto-type :initial-element ,(if (subtypep sto-type 'number) `(t/fid+ ,sto-type) nil))))))))
+
+(deft/method t/compute-store-size (sym compressed-sparse-matrix) (size)
+ `(destructuring-bind (nr nc &optional nz) ,size
+ (list nc (or nz (min (ceiling (* nr nc *default-sparsity*)) *max-sparse-size*)))))
+
+(deft/method t/store-type (sym compressed-sparse-matrix) (&optional (size '*))
+ `(simple-array ,(store-element-type sym) (,size)))
+
+(deft/method t/store-ref (sym compressed-sparse-matrix) (store &rest idx)
+ (assert (null (cdr idx)) nil "given more than one index for compressed-store")
+ `(aref (the ,(store-type sym) ,store) (the index-type ,(car idx))))
+
+(deft/method t/store-size (sym compressed-sparse-matrix) (ele)
+ `(length ,ele))
+
+(deft/method t/store-element-type (sym compressed-sparse-matrix) ()
+ (macroexpand `(t/field-type ,sym)))
+
+;;
+(deft/method t/store-set (sym compressed-sparse-matrix) (value store &rest idx)
+ (assert (null (cdr idx)) nil "given more than one index for compressed store")
+ `(setf (aref (the ,(store-type sym) ,store) (the index-type ,(car idx))) (the ,(field-type sym) ,value)))
+;; (deft/method t/store-set (sym coordinate-sparse-tensor) (value store &rest idx)
+;; (assert (null (cdr idx)) nil "given more than one index for hashtable.")
+;; (with-gensyms (val)
+;; `(let-typed ((,val ,value :type ,(field-type sym)))
+;; (unless (t/f= ,(field-type sym) ,val (t/fid+ ,(field-type sym)))
+;; (setf (gethash ,(car idx) ,store) (the ,(field-type sym) ,value))))))
+
+
+;;
+(defmethod ref ((tensor compressed-sparse-matrix) &rest subscripts)
+ (let ((clname (class-name (class-of tensor))))
+ (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
+ (compile-and-eval
+ `(defmethod ref ((tensor ,clname) &rest subscripts)
+ (let ((idx (compressed-sparse-indexing (if (numberp (car subscripts)) subscripts (car subscripts)) tensor)))
+ (if (< idx 0)
+ (t/sparse-fill ,clname)
+ (t/store-ref ,clname (store tensor) idx)))))
+ (apply #'ref (cons tensor subscripts))))
+
+#+nil
+(defmethod (setf ref) (value (tensor compressed-sparse-matrix) &rest subscripts)
+ (let ((clname (class-name (class-of tensor))))
+ (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
+ (compile-and-eval
+ `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts)
+ (let* ((subs (if (numberp (car subscripts)) subscripts (car subscripts)))
+ (idx (store-indexing subs tensor))
+ (sto (store tensor)))
+ (t/store-set ,clname (t/coerce ,(field-type clname) value) sto idx)
+ (t/store-ref ,clname sto idx))))
+ (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value)))
+;;
+(defleaf real-compressed-sparse-matrix (compressed-sparse-matrix) ())
+(deft/method t/field-type (sym real-compressed-sparse-matrix) ()
+ 'double-float)
+
+;;
+(defmethod :before copy! ((a sparse-tensor) (b sparse-tensor))
+ (assert (< (store-size a) (store-size b)) nil 'tensor-insufficient-store))
+
+(deft/method t/zeros (class compressed-sparse-matrix) (dims &optional nz)
+ `(destructuring-bind (vi vr vd) (t/store-allocator ,class (append ,dims ,@(when nz `((list ,nz)))))
+ (make-instance ',class
+ :dimensions (make-index-store ,dims)
+ :neighbour-start vi
+ :neighbour-id vr
+ :store vd)))
+
+(defmethod copy! ((x coordinate-sparse-tensor) (y compressed-sparse-matrix))
+ (let ((clx (class-name (class-of x)))
+ (cly (class-name (class-of y))))
+ (assert (and (member clx *tensor-type-leaves*)
+ (member cly *tensor-type-leaves*))
+ nil 'tensor-abstract-class :tensor-class (list clx cly))
+ (compile-and-eval
+ `(defmethod copy! ((x ,clx) (y ,cly))
+ (let-typed ((stds (strides x) :type index-store-vector))
+ (assert (and (tensor-matrixp x) (= (aref stds 0) 1)) nil 'tensor-invalid-stride-value)
+ (let ((col-stride (aref stds 1))
+ (row-data (make-array (ncols x) :initial-element nil)))
+ (very-quickly
+ (loop :for key :being :the :hash-keys :of (store x)
+ :using (hash-value value)
+ :do (multiple-value-bind (c r) (floor (the index-type key) col-stride)
+ (push (cons r value) (aref row-data c)))))
+ (let-typed ((vi (neighbour-start y) :type index-store-vector)
+ (vr (neighbour-id y) :type index-store-vector)
+ (vd (store y) :type ,(store-type cly)))
+ (setf (aref vi 0) 0)
+ (very-quickly
+ (loop :for i :from 0 :below (ncols x)
+ :with col-stop := 0
+ :do (let ((rowd (sort (aref row-data i) #'(lambda (x y) (< (the index-type x) (the index-type y))) :key #'car)))
+ (loop :for (r . v) :in rowd
+ :do (locally
+ (declare (type ,(field-type clx) v))
+ (setf (aref vr col-stop) r)
+ (t/store-set real-compressed-sparse-matrix (t/coerce ,(field-type cly) v) vd col-stop)
+ (incf col-stop)))
+ (setf (aref vi (1+ i)) col-stop)))))
+ y))))
+ (copy! x y)))
+
+(defmethod copy-generic ((a sparse-tensor) (type (eql 'real-compressed-sparse-matrix)))
+ (let-typed ((stds (strides a) :type index-store-vector))
+ (assert (and (tensor-matrixp a) (= (aref stds 0) 1)) nil 'tensor-not-matrix)
+ (let ((col-stride (aref stds 1))
+ (row-data (make-array (ncols a) :initial-element nil)))
+ (loop :for key :being :the :hash-keys :of (store a)
+ :using (hash-value value)
+ :do (multiple-value-bind (c r) (floor key col-stride)
+ (push (cons r value) (aref row-data c))))
+ (destructuring-bind (vi vr vd) (t/store-allocator real-compressed-sparse-matrix (append (dims a) (list (store-size a))))
+ (setf (aref vi 0) 0)
+ (loop :for i :from 0 :below (ncols a)
+ :with col-stop := 0
+ :do (let ((rowd (sort (aref row-data i) #'< :key #'car)))
+ (loop :for (r . v) :in rowd
+ :do (progn
+ (setf (aref vr col-stop) r
+ (aref vd col-stop) v)
+ (incf col-stop)))
+ (setf (aref vi (1+ i)) col-stop)))
+ (make-instance 'real-compressed-sparse-matrix
+ :dimensions (copy-seq (dimensions a))
+ :neighbour-start vi
+ :neighbour-id vr
+ :store vd)))))
diff --git a/src/base/coordinate-sparse.lisp b/src/base/coordinate-sparse.lisp
new file mode 100644
index 0000000..2365eb0
--- /dev/null
+++ b/src/base/coordinate-sparse.lisp
@@ -0,0 +1,82 @@
+(in-package :matlisp)
+
+;;One may to do better than a Hash-table for this.
+(defparameter *default-sparsity* 1/1000)
+(defparameter *max-sparse-size* 10000)
+
+(defclass coordinate-sparse-tensor (sparse-tensor)
+ ((strides :initarg :strides :reader strides :type index-store-vector
+ :documentation "Strides for accesing elements of the tensor.")))
+
+(deft/generic (t/sparse-fill #'subtypep) sym ())
+(deft/method t/sparse-fill (sym sparse-tensor) ()
+ `(t/fid+ (t/field-type ,sym)))
+
+(deft/method t/store-allocator (sym coordinate-sparse-tensor) (size &optional initial-element)
+ (with-gensyms (size-sym)
+ `(let ((,size-sym (t/compute-store-size ,sym ,size)))
+ (make-hash-table :size ,size-sym))))
+
+(deft/method t/store-ref (sym coordinate-sparse-tensor) (store &rest idx)
+ (assert (null (cdr idx)) nil "given more than one index for hashtable.")
+ `(the ,(field-type sym) (gethash ,(car idx) ,store (t/sparse-fill ,sym))))
+
+(deft/method t/store-set (sym coordinate-sparse-tensor) (value store &rest idx)
+ (assert (null (cdr idx)) nil "given more than one index for hashtable.")
+ (with-gensyms (val)
+ `(let-typed ((,val ,value :type ,(field-type sym)))
+ (unless (t/f= ,(field-type sym) ,val (t/fid+ ,(field-type sym)))
+ (setf (gethash ,(car idx) ,store) (the ,(field-type sym) ,value))))))
+
+(deft/method t/store-type (sym coordinate-sparse-tensor) (&optional (size '*))
+ 'hash-table)
+
+(deft/method t/store-size (sym coordinate-sparse-tensor) (ele)
+ `(hash-table-count ,ele))
+
+(deft/method t/store-type (sym coordinate-sparse-tensor) (&optional (size '*))
+ 'hash-table)
+
+(deft/method t/compute-store-size (sym coordinate-sparse-tensor) (size)
+ `(max (min sb-impl::+min-hash-table-size+ (ceiling (/ ,size *default-sparsity*))) *max-sparse-size*))
+
+(defmethod head ((tensor coordinate-sparse-tensor))
+ 0)
+;firefox;
+(defleaf real-coordinate-sparse-tensor (coordinate-sparse-tensor) ())
+
+(deft/method t/field-type (sym real-coordinate-sparse-tensor) ()
+ 'double-float)
+;;
+(defmethod ref ((tensor coordinate-sparse-tensor) &rest subscripts)
+ (let ((clname (class-name (class-of tensor))))
+ (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
+ (compile-and-eval
+ `(defmethod ref ((tensor ,clname) &rest subscripts)
+ (let ((subs (if (numberp (car subscripts)) subscripts (car subscripts))))
+ (t/store-ref ,clname (store tensor) (store-indexing subs tensor)))))
+ (apply #'ref (cons tensor subscripts))))
+
+(defmethod (setf ref) (value (tensor coordinate-sparse-tensor) &rest subscripts)
+ (let ((clname (class-name (class-of tensor))))
+ (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
+ (compile-and-eval
+ `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts)
+ (let* ((subs (if (numberp (car subscripts)) subscripts (car subscripts)))
+ (idx (store-indexing subs tensor))
+ (sto (store tensor)))
+ (t/store-set ,clname (t/coerce ,(field-type clname) value) sto idx)
+ (t/store-ref ,clname sto idx))))
+ (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value)))
+;;
+
+(deft/method t/zeros (class coordinate-sparse-tensor) (dims &optional initial-element)
+ (with-gensyms (astrs adims sizs)
+ `(let* ((,adims (make-index-store ,dims)))
+ (declare (type index-store-vector ,adims))
+ (multiple-value-bind (,astrs ,sizs) (make-stride-cmj ,adims)
+ (declare (type index-store-vector ,astrs))
+ (make-instance ',class
+ :dimensions ,adims
+ :strides ,astrs
+ :store (t/store-allocator ,class ,sizs))))))
diff --git a/src/base/loopopt.lisp b/src/base/loopopt.lisp
index 20c33b2..7c2257a 100644
--- a/src/base/loopopt.lisp
+++ b/src/base/loopopt.lisp
@@ -2,6 +2,10 @@
;;diagonal-copy
;; i, j; must be indices in some tensor.
+;; (with-tensors ((a .. :type real-tensor)
+;; (b .. :type real-tensor))
+;; :do (forall (i j) :st (= i j) :do (setf (ref a i j) (ref b i j))))
+
(defparameter *code*
`((forall (i j) :st (= i j) :do (setf (ref a i j) (ref b i j)))
(forall (i j) :st (= i j) :do (setf (ref a i j) (ref b i j)))
@@ -13,6 +17,12 @@
;;mod-loop
(forall (&rest idx) :order :col-major :st (< idx (dimensions a)) :do (setf (ref a idx) (ref b idx)))))
+;; `(let (,@stores
+;; ,@dimensions
+;; ,@strides
+;; ,@heads)
+
+
(defparameter *expr*
(mapcar #'(lambda (x) (find-tag x :do)) *code*))
diff --git a/src/base/print.lisp b/src/base/print.lisp
index 48b0042..f2441c3 100644
--- a/src/base/print.lisp
+++ b/src/base/print.lisp
@@ -112,7 +112,7 @@ of a matrix (default 0)
(defmethod print-object ((tensor sparse-tensor) stream)
(print-unreadable-object (tensor stream :type t)
- (format stream (if (slot-value tensor 'parent-tensor)
- "~A~,4T:DISPLACED"
- "~A")
- (dimensions tensor))))
+ (format stream
+ (string+ "~A, store-size: ~A"
+ (if (slot-value tensor 'parent-tensor) ",4T:DISPLACED" ""))
+ (dimensions tensor) (store-size tensor))))
diff --git a/src/base/sparse-tensor.lisp b/src/base/sparse-tensor.lisp
index 4119a3f..e69de29 100644
--- a/src/base/sparse-tensor.lisp
+++ b/src/base/sparse-tensor.lisp
@@ -1,134 +0,0 @@
-(in-package :matlisp)
-
-;;One may to do better than a Hash-table for this.
-(defparameter *default-sparsity* 1/1000)
-(defparameter *max-size* 10000)
-
-(defclass coordinate-sparse-tensor (sparse-tensor)
- ((strides :initarg :strides :reader strides :type index-store-vector
- :documentation "Strides for accesing elements of the tensor.")))
-
-(deft/generic (t/sparse-fill #'subtypep) sym ())
-(deft/method t/sparse-fill (sym sparse-tensor) ()
- `(t/fid+ (t/field-type ,sym)))
-
-(deft/method t/store-allocator (sym coordinate-sparse-tensor) (size &optional initial-element)
- (with-gensyms (size-sym)
- `(let ((,size-sym (t/compute-store-size ,sym ,size)))
- (make-hash-table :size ,size-sym))))
-
-(deft/method t/store-ref (sym coordinate-sparse-tensor) (store &rest idx)
- (assert (null (cdr idx)) nil "given more than one index for hashtable.")
- `(the ,(field-type sym) (gethash ,(car idx) ,store (t/sparse-fill ,sym))))
-
-(deft/method t/store-set (sym coordinate-sparse-tensor) (value store &rest idx)
- (assert (null (cdr idx)) nil "given more than one index for hashtable.")
- (with-gensyms (val)
- `(let-typed ((,val ,value :type ,(field-type sym)))
- (unless (t/f= ,(field-type sym) ,val (t/fid+ ,(field-type sym)))
- (setf (gethash ,(car idx) ,store) (the ,(field-type sym) ,value))))))
-
-(deft/method t/store-type (sym coordinate-sparse-tensor) (&optional (size '*))
- 'hash-table)
-
-(deft/method t/store-size (sym coordinate-sparse-tensor) (ele)
- `(hash-table-count ,ele))
-
-(deft/method t/store-type (sym coordinate-sparse-tensor) (&optional (size '*))
- 'hash-table)
-
-(deft/method t/compute-store-size (sym coordinate-sparse-tensor) (size)
- `(max (min sb-impl::+min-hash-table-size+ (ceiling (/ ,size *default-sparsity*))) *max-sparse-size*))
-
-(defmethod head ((tensor coordinate-sparse-tensor))
- 0)
-;;
-(defleaf real-sparse-tensor (coordinate-sparse-tensor) ())
-
-(deft/method t/field-type (sym real-sparse-tensor) ()
- 'double-float)
-;;
-(defmethod ref ((tensor coordinate-sparse-tensor) &rest subscripts)
- (let ((clname (class-name (class-of tensor))))
- (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
- (compile-and-eval
- `(defmethod ref ((tensor ,clname) &rest subscripts)
- (let ((subs (if (numberp (car subscripts)) subscripts (car subscripts))))
- (t/store-ref ,clname (store tensor) (store-indexing subs tensor)))))
- (apply #'ref (cons tensor subscripts))))
-
-(defmethod (setf ref) (value (tensor coordinate-sparse-tensor) &rest subscripts)
- (let ((clname (class-name (class-of tensor))))
- (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
- (compile-and-eval
- `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts)
- (let* ((subs (if (numberp (car subscripts)) subscripts (car subscripts)))
- (idx (store-indexing subs tensor))
- (sto (store tensor)))
- (t/store-set ,clname (t/coerce ,(field-type clname) value) sto idx)
- (t/store-ref ,clname sto idx))))
- (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value)))
-
-;;
-(defclass compressed-sparse-matrix (sparse-tensor)
- ((index-position :initarg :strides :reader index-position :type index-store-vector
- :documentation "Strides for accesing elements of the tensor.")
- (indices :initarg :strides :reader indices :type index-store-vector
- :documentation "Strides for accesing elements of the tensor.")))
-
-(defclass ccs-matrix (compressed-sparse-matrix) ())
-(defclass crs-matrix (compressed-sparse-matrix) ())
-
-
-(deft/method t/store-allocator (sym compressed-sparse-matrix) (size &optional initial-element)
- (using-gensyms (decl (size))
- `(let (,@decl)
- (destructuring-bind (ni nz) (t/compute-store-size ,sym ,size)
- (list
- (allocate-index-store ni)
- (allocate-index-store nz)
- (make-array nz :element-type ,(store-element-type sym) :initial-element ,(if (subtypep type 'number) `(t/fid+ ,type) nil)))))))
-
-(deft/method t/compute-store-size (sym ccs-matrix) (size)
- `(destructuring-bind (nr nc &optional nz) size
- (unless nz (setq nz (min (ceiling (* nr nc *default-sparsity*)) *max-sparse-size*)))
- (list nr nz nil)))
-
-(deft/method t/compute-store-size (sym ccs-matrix) (size)
- (using-gensyms (decl (size))
- `(let (,@decl)
- (destructuring-bind (nr nc &optional nz) size
- (unless nz (setq nz (min (ceiling (* nr nc *default-sparsity*)) *max-sparse-size*)))
- (list nc nz nil)))))
-
-(t/compute-store-size ccs-matrix '(10 10))
-(deft/method t/compute-store-size (sym ccr-matrix) (size)
- `(append ,size t))
-
-
-(deft/method t/compute-store-size (sym ccs-matrix) (size)
- `(max (min sb-impl::+min-hash-table-size+ (ceiling (/ ,size *default-sparsity*))) *max-size*))
-
-
-
-(defun coordinate->ccs (tensor)
- (assert (eql (nth-value 2 (blas-matrix-compatiblep tensor #\n)) :col-major) nil "nooo!")
- (labels ((rref (idx)
- (multiple-value-list (floor idx (col-stride tensor))))
- (convert-sto ()
- (let ((sto (store tensor))
- (nsto (make-hash-table)))
- (maphash #'(lambda (k v)
- (destructuring-bind (r c) (rref k)
- (unless (nth-value 1 (gethash c nsto))
- (setf (gethash c nsto) (cons nil nil)))
- (push r (car (gethash c nsto)))
- (push v (cdr (gethash c nsto)))))
- sto)
- (maphash #'(lambda (k v)
- (setf (car v) (make-index-store (car v))
- (cdr v) (make-array (length (cdr v)) :initial-contents (cdr v)))) nsto)
- nsto)))
- (convert-sto)))
-
-(defclass ccs-sparse-matrix (sparse-tensor) ())
diff --git a/src/blas/axpy.lisp b/src/blas/axpy.lisp
index 2e28522..48e2d7d 100644
--- a/src/blas/axpy.lisp
+++ b/src/blas/axpy.lisp
@@ -100,7 +100,7 @@
Same as AXPY except that the result
is stored in Y and Y is returned.
")
- (:method :before ((alpha number) (x standard-tensor) (y standard-tensor))
+ (:method :before ((alpha number) (x base-tensor) (y base-tensor))
(assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
'tensor-dimension-mismatch)))
diff --git a/src/blas/copy.lisp b/src/blas/copy.lisp
index 12c6b41..af584dd 100644
--- a/src/blas/copy.lisp
+++ b/src/blas/copy.lisp
@@ -120,7 +120,7 @@
,y))))
;;
-(defmethod copy! :before ((x standard-tensor) (y standard-tensor))
+(defmethod copy! :before ((x base-tensor) (y base-tensor))
(assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil
'tensor-dimension-mismatch))
@@ -178,3 +178,4 @@
((or (not type) (subtypep type 'standard-tensor))
(let ((ret (zeros (dimensions tensor) (or type (class-of tensor)))))
(copy! tensor ret)))))
+
diff --git a/src/blas/maker.lisp b/src/blas/maker.lisp
index 0a86d0b..cffe047 100644
--- a/src/blas/maker.lisp
+++ b/src/blas/maker.lisp
@@ -11,51 +11,50 @@
:dimensions ,adims
:head 0
:strides ,astrs
- :store (t/store-allocator ,class ,sizs ,@(when initial-element `(,initial-element))))))))
-
-;; (deft/method t/zeros (class coordinate-sparse-tensor) (dims &optional initial-element)
-;; (with-gensyms (astrs adims sizs)
-;; `(let* ((,adims (make-index-store ,dims)))
-;; (declare (type index-store-vector ,adims))
-;; (multiple-value-bind (,astrs ,sizs) (make-stride ,adims)
-;; (declare (type index-store-vector ,astrs))
-;; (make-instance ',class
-;; :dimensions ,adims
-;; :strides ,astrs
-;; :store (t/store-allocator ,class ,sizs))))))
-
-;; (deft/method t/zeros (class compressed-sparse-matrix) (dims &optional initial-element)
-;; (assert (= (length dims) 2) nil 'tensor-not-matrix)
-;; (with-gensyms (adims az ar ac)
-;; `(let* ((,adims (make-index-store ,dims))
-;; (,ar ,(first dims))
-;; (,ac ,(second dims))
-;; (,az (min (ceiling (* ,ar ,ac *default-sparsity*)) *max-sparse-size*)))
-;; (declare (type index-store-vector ,adims))
-;; (destructuring-bind (idxp idxi dat) (t/store-allocator ,class (t/compute-store-size ,class (list ,ar ,ac ,az)))
-;; (make-instance ',class
-;; :dimensions ,adims
-;; :index-position idxp
-;; :indices idxi
-;; :store dat)))))
+ :store (t/store-allocator ,class ,sizs ,@(when initial-element `((t/coerce ,(field-type class) ,initial-element)))))))))
;;
-(defgeneric zeros-generic (dims dtype)
- (:documentation "Create a tensor with dimensions @arg{dims} of class @arg{dtype}.")
- (:method ((dims cons) (dtype t))
+(defgeneric zeros-generic (dims dtype &optional initial-element)
+ (:documentation "A generic version of @func{zeros}.")
+ (:method ((dims cons) (dtype t) &optional initial-element)
;; (assert (member dtype *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class dtype)
(compile-and-eval
- `(defmethod zeros-generic ((dims cons) (dtype (eql ',dtype)))
- (t/zeros ,dtype dims)))
- (zeros-generic dims dtype)))
+ `(defmethod zeros-generic ((dims cons) (dtype (eql ',dtype)) &optional initial-element)
+ (if initial-element
+ (t/zeros ,dtype dims initial-element)
+ (t/zeros ,dtype dims))))
...
[truncated message content] |
