fastmap.lsp

   1 ;;;; fastmap -- Fast version of MAP
   2 ;;;;
   3 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
   4 ;;;; unrestricted use.
   5 ;;;;
   6 ;;;; The FASTMAP function is a version of MAP that is assumed to
   7 ;;;;
   8 ;;;;   a) be reasonable fast on any combination of lists and vectors
   9 ;;;;      as its arguments
  10 ;;;;
  11 ;;;;   b) not hang if at least one of its arguments is not a circular
  12 ;;;;      list.
  13 ;;;;
  14 ;;;; This function is the core of the vectorized arithmetic system, so it
  15 ;;;; may be worth optimizing for each CL implementation. I tried to improve
  16 ;;;; it for (A)KCL but have not yet been able to obtain a significant
  17 ;;;; increase in speed.
  18
  19 ;;;;
  20 ;;;; Package Setup
  21 ;;;;
  22
  23
  24 (in-package #:lisp-stat-basics)
  25
  26 ;;;;
  27 ;;;; Functions
  28 ;;;;
  29
  30 (defun cdr-lists (args)
  31   (do ((list args (cdr list))) ((null list))
  32       (if (consp (car list)) (rplaca list (cdar list)))))
  33
  34 (defun get-result-size (args)
  35   (macrolet ((any-nulls (ls) `(dolist (x ,ls) (if (null x) (return t)))))
  36     (let ((lists nil)
  37           (n nil))
  38       (dolist (x args)
  39         (if (consp x)
  40           (push x lists)
  41           (setf n (if n (min n (length x)) (length x)))))
  42       (cond
  43        ((and n lists)
  44         (let ((m 0))
  45           (loop
  46            (if (or (<= n m) (any-nulls lists)) (return))
  47            (cdr-lists lists)
  48            (incf m))
  49           (min n m)))
  50        (lists
  51         (let ((m 0))
  52           (loop
  53            (if (any-nulls lists) (return))
  54            (cdr-lists lists)
  55            (incf m))
  56           m))
  57        (t n)))))
  58
  59 (defun fastmap (type fcn &rest args)
  60   (cond ((and (eq type 'list) (every #'listp args))
  61          (apply #'mapcar fcn args))
  62         ((and (eq type 'vector) (every #'vectorp args))
  63          (apply #'map 'vector fcn args))
  64         ((every #'sequencep args)
  65          (let* ((n (get-result-size args))
  66                 (result (make-sequence type n))
  67                 (farg (make-list (length args))))
  68            (declare (fixnum n))
  69            (macrolet ((fill-arglist ()
  70                         `(do ((f farg (cdr f))
  71                               (a args (cdr a)))
  72                              ((null f))
  73                            (rplaca f
  74                                    (if (consp (car a))
  75                                      (caar a)
  76                                      (aref (car a) i))))))
  77              (if (consp result)
  78                (let ((r result))
  79                  (dotimes (i n result)
  80                    (declare (fixnum i))
  81                    (fill-arglist)
  82                    (rplaca r (apply fcn farg))
  83                    (setf r (cdr r))
  84                    (cdr-lists args)))
  85                (dotimes (i n result)
  86                  (declare (fixnum i))
  87                  (fill-arglist)
  88                  (setf (aref result i) (apply fcn farg))
  89                  (cdr-lists args))))))
  90         (t (error "not all sequences"))))