home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / XLISP 2.0 / XLISP Tools / Utility (UL) / ARRAY.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-04-07  |  4.1 KB  |  137 lines  |  [TEXT/ttxt]
  1. ;; Larry Mulcahy 1988
  2. ;; array functions
  3.  
  4. (provide 'array)
  5. (require 'iteration "iter")
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ; vector-equal 
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (defun vector-equal (v1 v2)
  12.   (and (arrayp v1)
  13.        (arrayp v2)
  14.        (let
  15.        ((big-v1 (length v1))
  16.         (big-v2 (length v2)))
  17.      (and (= big-v1 big-v2)
  18.           (let ((done nil)
  19.             (mismatch nil)
  20.             (index 0))
  21.         (while (and (not done) (not mismatch))
  22.           (setq mismatch (not (equal (aref v1 index)
  23.                                              (aref v2 index)))
  24.             index (1+ index)
  25.             done (>= index big-v1)))
  26.         (not mismatch))))))
  27.  
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29. ; mapvector 
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31.  
  32. (defun mapvector (f v)
  33.   (let*
  34.     ((big (length v))
  35.      (result (make-array big)))
  36.     (dotimes (i big)
  37.       (setf (aref result i) (funcall f (aref v i))))
  38.     result))
  39.  
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41. ; list-to-vector 
  42. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43.  
  44. (defun list-to-vector (l) (apply #'vector l))
  45.  
  46. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47. ; vector-to-list 
  48. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49.  
  50. (defun vector-to-list (v)
  51.   (let ((big (length v))
  52.     (result nil))
  53.     (for i 1 big (push (aref v (- big i)) result))
  54.     result))
  55.  
  56. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57. ; concatenate-two-vectors 
  58. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  59.  
  60. (defun concatenate-two-vectors (v1 v2)
  61.   (let*
  62.     ((big-v1 (length v1))
  63.      (big-v2 (length v2))
  64.      (big (+ big-v1 big-v2))
  65.      (result (make-array big)))
  66.     (dotimes (i big-v1)
  67.       (setf (aref result i) (aref v1 i)))
  68.     (dotimes (i big-v2)
  69.       (setf (aref result (+ i big-v1)) (aref v2 i)))
  70.     result))
  71.  
  72. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73. ; concatenate-vectors 
  74. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  75.  
  76. (defun concatenate-vectors (&rest vs)
  77.   (case (length vs)
  78.     (0 nil)
  79.     (1 (car vs))
  80.     (2 (concatenate-two-vectors (car vs) (cadr vs)))
  81.     (t (concatenate-two-vectors (car vs)
  82.                                 (apply #'concatenate-vectors
  83.                                        (cdr vs))))))
  84.  
  85. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  86. ; exchange-vector-elements 
  87. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  88.  
  89. (defmacro exchange-vector-elements (v i j)
  90.   (let ((temp-label (gensym)))
  91.     `(let
  92.        ((,temp-label (aref ,v ,i)))
  93.        (setf (aref ,v ,i) (aref ,v ,j))
  94.        (setf (aref ,v ,j) ,temp-label))))
  95.  
  96. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97. ; copy-vector 
  98. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99.  
  100. (defun copy-vector (v)
  101.   (let* ((big (length v))
  102.          (result (make-array big)))
  103.     (dotimes (i big)
  104.       (setf (aref result i) (aref v i)))
  105.     result))
  106.  
  107. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  108. ; vector:position
  109. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  110. ; return the 0-origin position of the first occurrence of the
  111. ; element e in the list l.
  112. ; If not found, return nil.
  113. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  114.  
  115. (defun vector:position (e v)
  116.   (dotimes (i (length v) nil)
  117.        (if (equal e (aref v i))
  118.            (return i))))
  119.  
  120. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  121. ; vector:position-if
  122. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  123.  
  124. (defun vector:position-if (test v)
  125.   (dotimes (i (length v) nil)
  126.        (if (funcall test (aref v i)) (return i))))
  127.  
  128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  129. ; vector:position-if-not
  130. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  131.  
  132. (defun vector:position-if-not (test v)
  133.   (dotimes (i (length v) nil)
  134.        (if (not (funcall test (aref v i))) (return i))))
  135.  
  136.  
  137.