merged from ansiClib
[CommonLispStat.git] / fastmap.lsp
blob2a50b4f025a4127913110125e07ab7a806ff381f
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.
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.
24 ;;;;
25 ;;;; Package Setup
26 ;;;;
28 (defpackage :lisp-stat-fastmap
29 (:use :common-lisp)
30 (:export fastmap))
32 (in-package :lisp-stat-fastmap)
34 ;;;;
35 ;;;; Functions
36 ;;;;
38 (defun sequencep (x)
39 "Args: (x)
40 Returns NIL unless X is a list or vector."
41 (or (listp x) (vectorp x)))
43 (defun cdr-lists (args)
44 (do ((list args (cdr list)))
45 ((null list))
46 (if (consp (car list)) (rplaca list (cdar list)))))
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)))))
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"))))