util.lisp (1603B)
1 (defpackage :util 2 (:use :common-lisp) 3 (:export :essentially-zerop 4 :list-permute 5 :multi-index-sequence 6 :indices-position 7 :indices-shape 8 :make-indices-permutation)) 9 10 (in-package :util) 11 12 (declaim (inline essentially-zerop)) 13 14 (defun essentially-zerop (number &optional (epsilon double-float-epsilon)) 15 (<= (abs number) epsilon)) 16 17 (defun list-permute (list permutation) 18 (let* ((n (length list)) 19 (l (make-list n))) 20 (dotimes (i n l) 21 (setf (nth (nth i permutation) l) (nth i list))))) 22 23 (defun multi-index-sequence (dimensions) 24 (if (zerop (length dimensions)) 25 '(nil) 26 (let ((m (multi-index-sequence (cdr dimensions)))) 27 (loop for i below (car dimensions) append 28 (loop for x in m collect (cons i x)))))) 29 30 (defun indices-position (rank indices) 31 (labels ((incp (seq &optional (i (car seq))) 32 (cond ((null seq) t) 33 ((eql (car seq) i) (incp (cdr seq) (1+ i))) 34 (t nil)))) 35 (let* ((s (sort (copy-list indices) #'<))) 36 (when (incp s) 37 (cond ((or (null s) (eql (car s) 0)) :left) 38 ((eql (1+ (car (last s))) rank) :right) 39 (t nil)))))) 40 41 (defun indices-shape (indices) 42 (when (car indices) 43 (let ((d (loop for i in indices minimize i))) 44 (mapcar #'(lambda (x) (- x d)) indices)))) 45 46 (defun make-indices-permutation (rank ia ib) 47 (let ((l (loop for i below rank collect i)) 48 (p (make-list rank :initial-element nil))) 49 (mapc #'(lambda (i j) 50 (setf (nth i p) j) 51 (setf l (delete j l))) 52 ia 53 ib) 54 (do ((x p (cdr x))) 55 ((null x) p) 56 (if (null (car x)) 57 (setf (car x) (pop l))))))