utils.lisp

   1 (in-package :cl-tuples)
   2
   3 ;; float that fits within range of x86 hardware register minus tag (rather sbcl oriented)
   4 (deftype fast-float ()
   5   #+sbcl `(single-float   (#.(- (expt 2f0 63))) (#.(expt 2f0 63)))
   6   #-sbcl 'single-float)
   7
   8 (defconstant fast-pi
   9   #.(coerce pi 'fast-float))
  10
  11 ;; TO DO -- possibly can be replaced by alexandria::symbolicate -- must check
  12 (defun make-adorned-symbol (name &key prefix suffix asterisk package)
  13   "Construct symbol for use as a function name, prefixed or suffixed
  14 with some string, and optionally an added asterisk"
  15   (check-type name (or string symbol))
  16   (check-type prefix (or symbol string null))
  17   (check-type suffix (or symbol string null))
  18   (intern (concatenate 'string
  19                        (when prefix
  20                          (string prefix))
  21                        (when prefix  "-")
  22                        (string name)
  23                        (when suffix
  24                          "-")
  25                        (when suffix
  26                          (string suffix))
  27                        (when asterisk
  28                          (string "*")))
  29           (if package package *package*)))
  30
  31 (defun last-char (str)
  32   (char str (1- (length str))))
  33
  34 (defun symbol-to-string (sym)
  35   "If the argument is a symbol or string, return it as a string."
  36   (check-type sym (or symbol string))
  37   (cond
  38     ((symbolp sym)
  39      (symbol-name sym))
  40     ((stringp sym)
  41      sym)))
  42
  43 (defun is-asterisk-symbol (s)
  44   (let
  45           ((ss (symbol-to-string s)))
  46         (eql (aref ss (1- (length ss))) #\*)))
  47
  48
  49 (defmacro multiply-arguments (operator factor arguments)
  50   `(,operator ,@(mapcar (lambda (argument) `(* ,factor ,argument)) arguments)))
  51
  52 (defun matrix-symbol (i j &optional (prefix '#:e))
  53   "Construct a symbol that will represent an elemnet of a matrix."
  54   (find-symbol (format NIL "~A~D~D" prefix i j) #.(find-package '#:cl-tuples)))
  55
  56 (defun matrix-minor (x y length &optional (prefix '#:e))
  57   (let ((symbol-prefix (format NIL "~A~D~:*~D" '#:matrix (1- length))))
  58     `(,(find-symbol (concatenate 'string symbol-prefix #.(string '#:-determinant*)) #.(find-package '#:cl-tuples))
  59       (,(find-symbol (concatenate 'string symbol-prefix #.(string '#:-values*)) #.(find-package '#:cl-tuples))
  60        ,@(iterate values
  61            (for i from 1 to length)
  62            (iterate
  63              (for j from 1 to length)
  64              (unless (or (eql i x) (eql j y))
  65                (in values (collect (matrix-symbol (1- i) (1- j) prefix))))))))))
  66
  67 (defun matrix-cofactors (length)
  68   (iterate values
  69     (for i from 1 to length)
  70     (iterate
  71       (for j from 1 to length)
  72       (for value = (matrix-minor i j length))
  73       (in values
  74           (collect (if (oddp (+ i j))
  75                        `(- ,value)
  76                        value))))))