| 1 | ;;; bit-array-ops.lisp |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2003-2005 Peter Graves |
|---|
| 4 | ;;; $Id: bit-array-ops.lisp 15569 2022-03-19 12:50:18Z mevenson $ |
|---|
| 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 | ;;; As a special exception, the copyright holders of this library give you |
|---|
| 21 | ;;; permission to link this library with independent modules to produce an |
|---|
| 22 | ;;; executable, regardless of the license terms of these independent |
|---|
| 23 | ;;; modules, and to copy and distribute the resulting executable under |
|---|
| 24 | ;;; terms of your choice, provided that you also meet, for each linked |
|---|
| 25 | ;;; independent module, the terms and conditions of the license of that |
|---|
| 26 | ;;; module. An independent module is a module which is not derived from |
|---|
| 27 | ;;; or based on this library. If you modify this library, you may extend |
|---|
| 28 | ;;; this exception to your version of the library, but you are not |
|---|
| 29 | ;;; obligated to do so. If you do not wish to do so, delete this |
|---|
| 30 | ;;; exception statement from your version. |
|---|
| 31 | |
|---|
| 32 | ;;; Adapted from CMUCL. |
|---|
| 33 | |
|---|
| 34 | (in-package #:system) |
|---|
| 35 | |
|---|
| 36 | (defun bit-array-same-dimensions-p (array1 array2) |
|---|
| 37 | (declare (type (array bit) array1 array2)) |
|---|
| 38 | (and (= (array-rank array1) |
|---|
| 39 | (array-rank array2)) |
|---|
| 40 | (dotimes (index (array-rank array1) t) |
|---|
| 41 | (when (/= (array-dimension array1 index) |
|---|
| 42 | (array-dimension array2 index)) |
|---|
| 43 | (return nil))))) |
|---|
| 44 | |
|---|
| 45 | (defun require-same-dimensions (array1 array2) |
|---|
| 46 | (unless (bit-array-same-dimensions-p array1 array2) |
|---|
| 47 | (error 'program-error |
|---|
| 48 | "~S and ~S do not have the same dimensions." |
|---|
| 49 | array1 array2))) |
|---|
| 50 | |
|---|
| 51 | (defun pick-result-array (result-bit-array bit-array-1) |
|---|
| 52 | (case result-bit-array |
|---|
| 53 | ((t) bit-array-1) |
|---|
| 54 | ((nil) (make-array (array-dimensions bit-array-1) |
|---|
| 55 | :element-type 'bit |
|---|
| 56 | :initial-element 0)) |
|---|
| 57 | (t |
|---|
| 58 | (require-same-dimensions bit-array-1 result-bit-array) |
|---|
| 59 | result-bit-array))) |
|---|
| 60 | |
|---|
| 61 | (defun bit-and (bit-array-1 bit-array-2 &optional result-bit-array) |
|---|
| 62 | (require-same-dimensions bit-array-1 bit-array-2) |
|---|
| 63 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
|---|
| 64 | (if (and (simple-bit-vector-p bit-array-1) |
|---|
| 65 | (simple-bit-vector-p bit-array-2) |
|---|
| 66 | (simple-bit-vector-p result-bit-array)) |
|---|
| 67 | (%simple-bit-vector-bit-and bit-array-1 bit-array-2 result-bit-array) |
|---|
| 68 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
|---|
| 69 | (setf (row-major-aref result-bit-array i) |
|---|
| 70 | (logand (row-major-aref bit-array-1 i) |
|---|
| 71 | (row-major-aref bit-array-2 i))))))) |
|---|
| 72 | |
|---|
| 73 | (defun bit-ior (bit-array-1 bit-array-2 &optional result-bit-array) |
|---|
| 74 | (require-same-dimensions bit-array-1 bit-array-2) |
|---|
| 75 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
|---|
| 76 | (if (and (simple-bit-vector-p bit-array-1) |
|---|
| 77 | (simple-bit-vector-p bit-array-2) |
|---|
| 78 | (simple-bit-vector-p result-bit-array)) |
|---|
| 79 | (%simple-bit-vector-bit-ior bit-array-1 bit-array-2 result-bit-array) |
|---|
| 80 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
|---|
| 81 | (setf (row-major-aref result-bit-array i) |
|---|
| 82 | (logior (row-major-aref bit-array-1 i) |
|---|
| 83 | (row-major-aref bit-array-2 i))))))) |
|---|
| 84 | |
|---|
| 85 | (defun bit-xor (bit-array-1 bit-array-2 &optional result-bit-array) |
|---|
| 86 | (require-same-dimensions bit-array-1 bit-array-2) |
|---|
| 87 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
|---|
| 88 | (if (and (simple-bit-vector-p bit-array-1) |
|---|
| 89 | (simple-bit-vector-p bit-array-2) |
|---|
| 90 | (simple-bit-vector-p result-bit-array)) |
|---|
| 91 | (%simple-bit-vector-bit-xor bit-array-1 bit-array-2 result-bit-array) |
|---|
| 92 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
|---|
| 93 | (setf (row-major-aref result-bit-array i) |
|---|
| 94 | (logxor (row-major-aref bit-array-1 i) |
|---|
| 95 | (row-major-aref bit-array-2 i))))))) |
|---|
| 96 | |
|---|
| 97 | (defun bit-eqv (bit-array-1 bit-array-2 &optional result-bit-array) |
|---|
| 98 | (require-same-dimensions bit-array-1 bit-array-2) |
|---|
| 99 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
|---|
| 100 | (if (and (simple-bit-vector-p bit-array-1) |
|---|
| 101 | (simple-bit-vector-p bit-array-2) |
|---|
| 102 | (simple-bit-vector-p result-bit-array)) |
|---|
| 103 | (%simple-bit-vector-bit-eqv bit-array-1 bit-array-2 result-bit-array) |
|---|
| 104 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
|---|
| 105 | (setf (row-major-aref result-bit-array i) |
|---|
| 106 | (logand (logeqv (row-major-aref bit-array-1 i) |
|---|
| 107 | (row-major-aref bit-array-2 i)) |
|---|
| 108 | 1)))))) |
|---|
| 109 | |
|---|
| 110 | (defun bit-nand (bit-array-1 bit-array-2 &optional result-bit-array) |
|---|
| 111 | (require-same-dimensions bit-array-1 bit-array-2) |
|---|
| 112 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
|---|
| 113 | (if (and (simple-bit-vector-p bit-array-1) |
|---|
| 114 | (simple-bit-vector-p bit-array-2) |
|---|
| 115 | (simple-bit-vector-p result-bit-array)) |
|---|
| 116 | (%simple-bit-vector-bit-nand bit-array-1 bit-array-2 result-bit-array) |
|---|
| 117 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
|---|
| 118 | (setf (row-major-aref result-bit-array i) |
|---|
| 119 | (logand (lognand (row-major-aref bit-array-1 i) |
|---|
| 120 | (row-major-aref bit-array-2 i)) |
|---|
| 121 | 1)))))) |
|---|
| 122 | |
|---|
| 123 | (defun bit-nor (bit-array-1 bit-array-2 &optional result-bit-array) |
|---|
| 124 | (require-same-dimensions bit-array-1 bit-array-2) |
|---|
| 125 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
|---|
| 126 | (if (and (simple-bit-vector-p bit-array-1) |
|---|
| 127 | (simple-bit-vector-p bit-array-2) |
|---|
| 128 | (simple-bit-vector-p result-bit-array)) |
|---|
| 129 | (%simple-bit-vector-bit-nor bit-array-1 bit-array-2 result-bit-array) |
|---|
| 130 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
|---|
| 131 | (setf (row-major-aref result-bit-array i) |
|---|
| 132 | (logand (lognor (row-major-aref bit-array-1 i) |
|---|
| 133 | (row-major-aref bit-array-2 i)) |
|---|
| 134 | 1)))))) |
|---|
| 135 | |
|---|
| 136 | (defun bit-andc1 (bit-array-1 bit-array-2 &optional result-bit-array) |
|---|
| 137 | (require-same-dimensions bit-array-1 bit-array-2) |
|---|
| 138 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
|---|
| 139 | (if (and (simple-bit-vector-p bit-array-1) |
|---|
| 140 | (simple-bit-vector-p bit-array-2) |
|---|
| 141 | (simple-bit-vector-p result-bit-array)) |
|---|
| 142 | (%simple-bit-vector-bit-andc1 bit-array-1 bit-array-2 result-bit-array) |
|---|
| 143 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
|---|
| 144 | (setf (row-major-aref result-bit-array i) |
|---|
| 145 | (logand (logandc1 (row-major-aref bit-array-1 i) |
|---|
| 146 | (row-major-aref bit-array-2 i)) |
|---|
| 147 | 1)))))) |
|---|
| 148 | |
|---|
| 149 | (defun bit-andc2 (bit-array-1 bit-array-2 &optional result-bit-array) |
|---|
| 150 | (require-same-dimensions bit-array-1 bit-array-2) |
|---|
| 151 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
|---|
| 152 | (if (and (simple-bit-vector-p bit-array-1) |
|---|
| 153 | (simple-bit-vector-p bit-array-2) |
|---|
| 154 | (simple-bit-vector-p result-bit-array)) |
|---|
| 155 | (%simple-bit-vector-bit-andc2 bit-array-1 bit-array-2 result-bit-array) |
|---|
| 156 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
|---|
| 157 | (setf (row-major-aref result-bit-array i) |
|---|
| 158 | (logand (logandc2 (row-major-aref bit-array-1 i) |
|---|
| 159 | (row-major-aref bit-array-2 i)) |
|---|
| 160 | 1)))))) |
|---|
| 161 | |
|---|
| 162 | (defun bit-orc1 (bit-array-1 bit-array-2 &optional result-bit-array) |
|---|
| 163 | (require-same-dimensions bit-array-1 bit-array-2) |
|---|
| 164 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
|---|
| 165 | (if (and (simple-bit-vector-p bit-array-1) |
|---|
| 166 | (simple-bit-vector-p bit-array-2) |
|---|
| 167 | (simple-bit-vector-p result-bit-array)) |
|---|
| 168 | (%simple-bit-vector-bit-orc1 bit-array-1 bit-array-2 result-bit-array) |
|---|
| 169 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
|---|
| 170 | (setf (row-major-aref result-bit-array i) |
|---|
| 171 | (logand (logorc1 (row-major-aref bit-array-1 i) |
|---|
| 172 | (row-major-aref bit-array-2 i)) |
|---|
| 173 | 1)))))) |
|---|
| 174 | |
|---|
| 175 | (defun bit-orc2 (bit-array-1 bit-array-2 &optional result-bit-array) |
|---|
| 176 | (require-same-dimensions bit-array-1 bit-array-2) |
|---|
| 177 | (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) |
|---|
| 178 | (if (and (simple-bit-vector-p bit-array-1) |
|---|
| 179 | (simple-bit-vector-p bit-array-2) |
|---|
| 180 | (simple-bit-vector-p result-bit-array)) |
|---|
| 181 | (%simple-bit-vector-bit-orc2 bit-array-1 bit-array-2 result-bit-array) |
|---|
| 182 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
|---|
| 183 | (setf (row-major-aref result-bit-array i) |
|---|
| 184 | (logand (logorc2 (row-major-aref bit-array-1 i) |
|---|
| 185 | (row-major-aref bit-array-2 i)) |
|---|
| 186 | 1)))))) |
|---|
| 187 | |
|---|
| 188 | (defun bit-not (bit-array &optional result-bit-array) |
|---|
| 189 | (let ((result-bit-array (pick-result-array result-bit-array bit-array))) |
|---|
| 190 | (if (and (simple-bit-vector-p bit-array) |
|---|
| 191 | (simple-bit-vector-p result-bit-array)) |
|---|
| 192 | (%simple-bit-vector-bit-not bit-array result-bit-array) |
|---|
| 193 | (dotimes (i (array-total-size result-bit-array) result-bit-array) |
|---|
| 194 | (setf (row-major-aref result-bit-array i) |
|---|
| 195 | (logxor (row-major-aref bit-array i) 1)))))) |
|---|
