fastmap.lsp

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