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