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 (provide "fastmap")
  20
  21 ;;;;
  22 ;;;; Package Setup
  23 ;;;;
  24
  25 #+:CLtL2
  26 (in-package lisp-stat-basics)
  27 #-:CLtL2
  28 (in-package 'lisp-stat-basics)
  29
  30
  31 ;;;;
  32 ;;;; Functions
  33 ;;;;
  34
  35 (defun cdr-lists (args)
  36   (do ((list args (cdr list))) ((null list))
  37       (if (consp (car list)) (rplaca list (cdar list)))))
  38
  39 (defun get-result-size (args)
  40   (macrolet ((any-nulls (ls) `(dolist (x ,ls) (if (null x) (return t)))))
  41     (let ((lists nil)
  42           (n nil))
  43       (dolist (x args)
  44         (if (consp x)
  45           (push x lists)
  46           (setf n (if n (min n (length x)) (length x)))))
  47       (cond
  48        ((and n lists)
  49         (let ((m 0))
  50           (loop
  51            (if (or (<= n m) (any-nulls lists)) (return))
  52            (cdr-lists lists)
  53            (incf m))
  54           (min n m)))
  55        (lists
  56         (let ((m 0))
  57           (loop
  58            (if (any-nulls lists) (return))
  59            (cdr-lists lists)
  60            (incf m))
  61           m))
  62        (t n)))))
  63
  64 (defun fastmap (type fcn &rest args)
  65   (cond ((and (eq type 'list) (every #'listp args))
  66          (apply #'mapcar fcn args))
  67         ((and (eq type 'vector) (every #'vectorp args))
  68          (apply #'map 'vector fcn args))
  69         ((every #'sequencep args)
  70          (let* ((n (get-result-size args))
  71                 (result (make-sequence type n))
  72                 (farg (make-list (length args))))
  73            (declare (fixnum n))
  74            (macrolet ((fill-arglist ()
  75                         `(do ((f farg (cdr f))
  76                               (a args (cdr a)))
  77                              ((null f))
  78                            (rplaca f
  79                                    (if (consp (car a))
  80                                      (caar a)
  81                                      (aref (car a) i))))))
  82              (if (consp result)
  83                (let ((r result))
  84                  (dotimes (i n result)
  85                    (declare (fixnum i))
  86                    (fill-arglist)
  87                    (rplaca r (apply fcn farg))
  88                    (setf r (cdr r))
  89                    (cdr-lists args)))
  90                (dotimes (i n result)
  91                  (declare (fixnum i))
  92                  (fill-arglist)
  93                  (setf (aref result i) (apply fcn farg))
  94                  (cdr-lists args))))))
  95         (t (error "not all sequences"))))