1 | ;;; bit-array-ops.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003-2005 Peter Graves |
---|
4 | ;;; $Id: bit-array-ops.lisp,v 1.3 2005-02-12 21:11:46 piso Exp $ |
---|
5 | ;;; |
---|
6 | ;;; This program is free software; you can redistribute it and/or |
---|
7 | ;;; modify it under the terms of the GNU General Public License |
---|
8 | ;;; as published by the Free Software Foundation; either version 2 |
---|
9 | ;;; of the License, or (at your option) any later version. |
---|
10 | ;;; |
---|
11 | ;;; This program is distributed in the hope that it will be useful, |
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | ;;; GNU General Public License for more details. |
---|
15 | ;;; |
---|
16 | ;;; You should have received a copy of the GNU General Public License |
---|
17 | ;;; along with this program; if not, write to the Free Software |
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
19 | |
---|
20 | ;;; Adapted from CMUCL. |
---|
21 | |
---|
22 | (in-package #:system) |
---|
23 | |
---|
24 | (defun bit-array-same-dimensions-p (array1 array2) |
---|
25 | (declare (type (array bit) array1 array2)) |
---|
26 | (and (= (array-rank array1) |
---|
27 | (array-rank array2)) |
---|
28 | (dotimes (index (array-rank array1) t) |
---|
29 | (when (/= (array-dimension array1 index) |
---|
30 | (array-dimension array2 index)) |
---|
31 | (return nil))))) |
---|
32 | |
---|
33 | (defun require-same-dimensions (array1 array2) |
---|
34 | (unless (bit-array-same-dimensions-p array1 array2) |
---|
35 | (error 'program-error |
---|
36 | "~S and ~S do not have the same dimensions." |
---|
37 | array1 array2))) |
---|
38 | |
---|
39 | (defun pick-result-array (result-bit-array bit-array-1) |
---|
40 | (case result-bit-array |
---|
41 | ((t) bit-array-1) |
---|
42 | ((nil) (make-array (array-dimensions bit-array-1) |
---|
43 | :element-type 'bit |
---|
44 | :initial-element 0)) |
---|
45 | (t |
---|
46 | (require-same-dimensions bit-array-1 result-bit-array) |
---|
47 | result-bit-array))) |
---|
48 | |
---|
49 | (defmacro def-bit-array-op (name function) |
---|
50 | `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array) |
---|
51 | ,(format nil |
---|
52 | "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~ |
---|
53 | BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~ |
---|
54 | If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~ |
---|
55 | RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~ |
---|
56 | All the arrays must have the same rank and dimensions." |
---|
57 | (symbol-name function)) |
---|
58 | (require-same-dimensions bit-array-1 bit-array-2) |
---|
59 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
---|
60 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
---|
61 | (setf (row-major-aref result-bit-array i) |
---|
62 | (logand (,function (row-major-aref bit-array-1 i) |
---|
63 | (row-major-aref bit-array-2 i)) |
---|
64 | 1)))))) |
---|
65 | |
---|
66 | ;; (def-bit-array-op bit-and logand) |
---|
67 | ;; (def-bit-array-op bit-ior logior) |
---|
68 | ;; (def-bit-array-op bit-xor logxor) |
---|
69 | (def-bit-array-op bit-eqv logeqv) |
---|
70 | ;; (def-bit-array-op bit-nand lognand) |
---|
71 | (def-bit-array-op bit-nor lognor) |
---|
72 | (def-bit-array-op bit-andc1 logandc1) |
---|
73 | (def-bit-array-op bit-andc2 logandc2) |
---|
74 | (def-bit-array-op bit-orc1 logorc1) |
---|
75 | (def-bit-array-op bit-orc2 logorc2) |
---|
76 | |
---|
77 | (defun bit-and (bit-array-1 bit-array-2 &optional result-bit-array) |
---|
78 | (require-same-dimensions bit-array-1 bit-array-2) |
---|
79 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
---|
80 | (if (and (simple-bit-vector-p bit-array-1) |
---|
81 | (simple-bit-vector-p bit-array-2) |
---|
82 | (simple-bit-vector-p result-bit-array)) |
---|
83 | (%simple-bit-vector-bit-and bit-array-1 bit-array-2 result-bit-array) |
---|
84 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
---|
85 | (setf (row-major-aref result-bit-array i) |
---|
86 | (logand (row-major-aref bit-array-1 i) |
---|
87 | (row-major-aref bit-array-2 i))))))) |
---|
88 | |
---|
89 | (defun bit-ior (bit-array-1 bit-array-2 &optional result-bit-array) |
---|
90 | (require-same-dimensions bit-array-1 bit-array-2) |
---|
91 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
---|
92 | (if (and (simple-bit-vector-p bit-array-1) |
---|
93 | (simple-bit-vector-p bit-array-2) |
---|
94 | (simple-bit-vector-p result-bit-array)) |
---|
95 | (%simple-bit-vector-bit-ior bit-array-1 bit-array-2 result-bit-array) |
---|
96 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
---|
97 | (setf (row-major-aref result-bit-array i) |
---|
98 | (logior (row-major-aref bit-array-1 i) |
---|
99 | (row-major-aref bit-array-2 i))))))) |
---|
100 | |
---|
101 | (defun bit-xor (bit-array-1 bit-array-2 &optional result-bit-array) |
---|
102 | (require-same-dimensions bit-array-1 bit-array-2) |
---|
103 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
---|
104 | (if (and (simple-bit-vector-p bit-array-1) |
---|
105 | (simple-bit-vector-p bit-array-2) |
---|
106 | (simple-bit-vector-p result-bit-array)) |
---|
107 | (%simple-bit-vector-bit-xor bit-array-1 bit-array-2 result-bit-array) |
---|
108 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
---|
109 | (setf (row-major-aref result-bit-array i) |
---|
110 | (logxor (row-major-aref bit-array-1 i) |
---|
111 | (row-major-aref bit-array-2 i))))))) |
---|
112 | |
---|
113 | (defun bit-nand (bit-array-1 bit-array-2 &optional result-bit-array) |
---|
114 | (require-same-dimensions bit-array-1 bit-array-2) |
---|
115 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
---|
116 | (if (and (simple-bit-vector-p bit-array-1) |
---|
117 | (simple-bit-vector-p bit-array-2) |
---|
118 | (simple-bit-vector-p result-bit-array)) |
---|
119 | (%simple-bit-vector-bit-nand bit-array-1 bit-array-2 result-bit-array) |
---|
120 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
---|
121 | (setf (row-major-aref result-bit-array i) |
---|
122 | (logand (lognand (row-major-aref bit-array-1 i) |
---|
123 | (row-major-aref bit-array-2 i)) |
---|
124 | 1)))))) |
---|
125 | |
---|
126 | (defun bit-not (bit-array &optional result-bit-array) |
---|
127 | "Performs a bit-wise logical NOT on the elements of BIT-ARRAY, |
---|
128 | putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, |
---|
129 | BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is |
---|
130 | created. Both arrays must have the same rank and dimensions." |
---|
131 | (let ((result-bit-array (pick-result-array result-bit-array bit-array))) |
---|
132 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
---|
133 | (setf (row-major-aref result-bit-array i) |
---|
134 | (logxor (row-major-aref bit-array i) 1))))) |
---|