;;; -*- Syntax:Common-Lisp; Mode: LISP; Package: (TMS Lisp 1000.); Base: 10. -*-

(in-package 'tms)

"(c) Copyright 1986, 1987, 1988 Xerox Corporation.  All rights reserved.  Subject to
the following conditions, permission is granted to use and copy this
software and to prepare derivative works:  Such use, copying or
preparation of derivative works must be for non-commercial research or
educational purposes; each copy or derivative work must include this
copyright notice in full; a copy of each completed derivative work must
be returned to:  DEKLEER@XEROX.COM (Arpanet) or Johan de Kleer,
Xerox PARC, 3333 Coyote Hill Road, Palo Alto, CA 94304.  This software
is made available AS IS, and Xerox Corporation makes no warranty about
the software or its performance."

(defvar *break-coded* nil "NIL if simple bit vectors, T if break coded")

;;; The default hash functions provided by the LISPM are much much too slow.

;;; The following hash functions are rated on 8-queens by:
;;; <average probe length> <maximum probe length> <interpretation construction time>

;;; Picking a good hash function is very very hard.  If someone else
;;; has a better suggestion please let me know.
;;; Here are some of the ones I tried.

#+:CADR
(defun hash (assumptions &aux (hash 0))
  (mapc #'(lambda (a mask) (setq hash (logxor hash a mask))) assumptions *randoms*)
  (%logldb #o0027 hash))

;;; This hash function is truely horrible
;(defun hash (assumptions &aux (hash 0))
;  (dolist (a assumptions) (setq hash (%24-bit-plus hash a)))
;  (%logldb #o0027 hash))

#|

;;; 4.1 - 29
(defun hash-1 (assumptions &aux (hash 0))	
  (dolist (number assumptions)
    (setq hash (zl:%32-bit-plus (zl:rot hash (logand number #o37)) number)))
  (zl:%logldb (byte 31. 0) hash))

;;; 4.1 - 29.
(defun hash-2 (assumptions &aux (hash 0))	
  (dolist (number assumptions)
    (setq hash (zl:%32-bit-plus (zl:rot hash (logcount number)) number)))
  (zl:%logldb (byte 31. 0) hash))

;;; 3.5 - 13
(defun hash-3 (assumptions &aux (hash 0))	
  (dolist (number assumptions)
    (setq hash (+ (rem hash 33073) (rem (abs number) 33073))))
  hash)

;;; 1.7 - 34
(defun hash-4 (assumptions &aux (hash 0))
  (mapc #'(lambda (number mask) (setq hash (logxor hash (rem number 33073) mask)))
	assumptions *randoms*)
  (if (> hash 0) hash (+ hash most-positive-fixnum)))

;;; 1.22 - 11
(defun hash-5 (assumptions &aux (hash 0))
  (mapc #'(lambda (number mask) (setq hash (rem (logxor hash number mask) 960017.)))
	assumptions *randoms*)
  (if (> hash 0) hash (+ hash most-positive-fixnum)))

;;; 2.8 - 22
(defun hash-12 (assumptions &aux (hash 0))
  (mapc #'(lambda (number) (setq hash (rem (logxor hash number) 960017.)))
	assumptions)
  (if (> hash 0) hash (+ hash most-positive-fixnum)))

;;; 1.4 - 7 - 5.8 (and number conses).
(defun hash-7 (assumptions &aux (hash 0))
  (dolist (number assumptions)
    (setq hash (+ number (ash hash 32.))))
  (abs hash))

;;; 1.4 - 7 - 5.2 (equivalent to above without number consing).
(defun hash-8 (numbers &aux hash)
  (cond (numbers
	 (setq hash (rem (car numbers) 33073))
	 (dolist (number (cdr numbers))
	   (setq hash (rem (+ (* hash #.(rem (expt 2 32) 33073)) (rem number 33073)) 33073)))
	 (abs hash))
	(0)))

;;; 3.0 - 19
(defun hash-9 (assumptions &aux (hash 0))	
  (dolist (number assumptions)
    (setq hash (+ (rem hash 960017.) (rem (abs number) 960017.))))
  (abs hash))

;;; 1.9 - 29 - 5.74
(defun hash-10 (numbers) (abs (sxhash numbers)))

;;; 2.0 - 36 - 5.3
;;; **** all the hashes should be done like this.
#:+CL
(defun hash-11 (assumptions &aux (hash 0))
  (mapc #'(lambda (number mask) (setq hash (logxor hash number mask)))
	assumptions *randoms*)
  (if (> hash 0) hash (+ hash most-positive-fixnum)))

|#

;;; 1.16 - 5 - 5.2
(defun hash-bits (assumptions size &aux (hash 0))
  (mapc #'(lambda (number mask) (setq hash (rem (logxor hash number mask) size)))
	assumptions *randoms*)
  (if (> hash 0)
      hash
      (rem (+ hash most-positive-fixnum) size)))

;;; Another CommonLisp hash.
;;; This is trying to avoid creating a bignum.  
;;; It uses the sign bit.
;;;**** maybe this scheme can be generalized.
;;;**** it does not use the random scheme.  Think about this sometime.
;(defun hash (assumptions &aux (anti-hash most-positive-fixnum))
;  (dolist (a assumptions)
;    (setq a (logand a *word-value*))		
;    (decf anti-hash a)
;    (if (< anti-hash 0) (incf anti-hash *word-value*)))
;  (- *word-value* anti-hash))

#+:IL ;;;****** make + non number consing.
(defun hash (assumptions &aux (hash 0))	
  (dolist (a assumptions) (setq hash (imodplus hash a 15.)))
  (logand hash #.*word-value*))

;;; Simple utilities.
;;; Tests two bit vectors for equality.  Faster than EQUAL (I think).
(defun vector-equal-bits (l1 l2)
  (do ((l1 l1 (cdr l1))
       (l2 l2 (cdr l2)))
      ((eq l1 l2) T)
    (unless (eq (car l1) (car l2)) (return nil))))

;;; Fix callers some day.  Assumptions is not always sorted.  The maximum assumption
;;; is either max if non Nil.********* make-env-vector callers.


;;; This is a non-destructive vector cons, it returns the original input, if
;;; no bits have to change, otherwise it conses up an entire new one.
;(defun vector-cons1 (assumption vector)



;;; This vector-cons4 is given the hint that the new assumption is not in the vector.
;;; It does not do any destructive modification of the vector it is given.
;;; It tries to be more efficient than vector-cons1, but I haven't see it really make
;;; a difference anywhere.

;;; The result of a Vector-cons4 is never going to be modified.  So its worth trying
;;; to construct a cdr-coded list out of it in all cases.

;;; Break coded operations.

;;; Bit vector operations only.

;;; Bit vector hackery.


;;; Note that assumptions are created with node-status OUT because adding the justification
;;; brings them in.
(defun basic-make-assumption-internal-bits (count variable value datum
					    &aux offset bit assumption)
  (multiple-value-setq (offset bit) (floor count #.*word-size*))
  (setq assumption (internal-make-assumption count
					     variable
					     value
					     datum
					     'OUT
					     'DONT))
  (setf (assumption-offset assumption) offset)
  (setf (assumption-bits assumption) (set-bit 0 bit))
  (setf (assumption-mask assumption) (byte 1 bit))
  assumption)

;;; Array references are just too much of a pain and inefficient.  This implementation
;;; stores them as a list of 24 bit fixnums.  Temporarily made in 23, because this
;;; generates bignums otherwise.****** 
;;; ***** usually this list is sorted**** so this can be done more efficiently.
;;; ***** creitinous.
;;; ***** Why does this seem to sort over and over again?  
(defun make-env-vector-bits (assumptions &optional max &aux vector word)
  (if assumptions
      (setq vector (make-bit-vector (1+ (or max (assumption-offset (car assumptions)))))))
  (dolist (assumption assumptions)
    (setq word (nthcdr (assumption-offset assumption) vector))
    (rplaca word (logior (car word) (assumption-bits assumption))))
  vector)

;;; Soon there will be no point to sort assumptions.
(defun make-env-vector-bits* (assumptions &aux max new-max)
  (make-env-vector-bits assumptions
			(do ((assumptions assumptions (cdr assumptions)))
			    ((null assumptions) (or max 0))
			  (cond ((null max) (setq max (assumption-offset (car assumptions))))
				((> (setq new-max (assumption-offset (car assumptions))) max)
				 (setq max new-max))))))

;;; Remember that vectors in hash table are presumed trailing '0s dropped.  As
;;; a consequence the empty vector is () not (0).
(defun sanitize-vector (vector &aux last-nonzero)
  (if *break-coded* (error "Unimplemented"))
  (do ((vector vector (cdr vector)))
      ((null vector))
    (if (not= (car vector) 0) (setq last-nonzero vector)))
  (when last-nonzero (rplacd last-nonzero nil) vector))

(comment Not used
;;; This does no consing whatsoever if bit e is already on.
(defun vector-cons (e v &aux offset bit nv word)
  (multiple-value-setq (offset bit) (floor e #.*word-size*))
  (setq word (nthcdr offset v))
  (cond ((null word) 
	 (setq nv (make-bit-vector (1+ offset))
	       word (nthcdr offset nv))
	 (rplaca word (set-bit (car word) bit))
	 (do ((v v (cdr v))
	      (nv nv (cdr nv)))
	     ((null v))
	   (rplaca nv (car v)))
	 nv)
	((not= 0 (%logldb (byte 1 bit) (car word))) v)
	(t (setq nv (fcopylist v) word (nthcdr offset nv))
	   (rplaca word (set-bit (car word) bit))
	   nv))))

(comment Not used
;;; Some day determine whether cons2 is faster than cons1.
(defun vector-cons2 (offset mask v &aux nv word)
  (setq word (nthcdr offset v))
  (cond ((null word) 
	 (setq nv (make-bit-vector (1+ offset))
	       word (nthcdr offset nv))
	 (rplaca word (%logdpb (car word) mask 1))
	 (do ((v v (cdr v))
	      (nv nv (cdr nv)))
	     ((null v))
	   (rplaca nv (car v)))
	 nv)
	((not= 0 (%logldb mask (car word))) v)
	(t (setq nv (fcopylist v) word (nthcdr offset nv))
	   (rplaca word (%logdpb (car word) mask 1))
	   nv))))

;;; Why call this?
;;; This is a non-destructive vector cons, it returns the original input, if
;;; no bits have to change, otherwise it conses up an entire new one.
(defun vector-cons1-bits (assumption v &aux nv word offset bits)
  (setq offset (assumption-offset assumption)
	bits (assumption-bits assumption)
	word (nthcdr offset v))
  (cond ((null word) 
	 (setq nv (make-bit-vector (1+ offset))
	       word (nthcdr offset nv))
	 (rplaca word (logior (car word) bits))
	 (do ((v v (cdr v))
	      (nv nv (cdr nv)))
	     ((null v))
	   (rplaca nv (car v)))
	 nv)
	((not= 0 (logand bits (car word))) v)
	(t (setq nv (fcopylist v) word (nthcdr offset nv))
	   (rplaca word (logior (car word) bits))
	   nv)))

;;; Call this if you know the assumption will be a new addition. This guarantees
;;; to create a new structure.  It spends extra effort to create a cdr coded list.
;;; We need to experiment about what is faster here****
;;; *** emperically, the previuos version of vector-cons4-bits was a bit faster
;;; why?
(defun vector-cons4-bits (offset bits v &aux nv length)
  (setq length (length v)
	nv (make-bit-vector (if (> length offset) length (1+ offset))))
  (do ((i 0 (1+ i))
       (v v (cdr v))
       (nv nv (cdr nv)))
      (nil)
    (cond (v (rplaca nv (if (= i offset) (logior (car v) bits) (car v))))
	  ((> i offset) (return nil))
	  (t (do ((i i (1+ i))) (nil)
	       (when (= i offset) (rplaca nv bits) (return-from nil))
	       (setq nv (cdr nv)))
	     (return nil))))
  nv)


;;; A destructive vector-cons, but works to maintain cdr coded list.

(defun vector-cons3-bits (a v &aux offset bits nv word)
  (setq offset (assumption-offset a)
	bits (assumption-bits a)
	word (nthcdr offset v))
  (cond ((null word) 
	 (setq nv (make-bit-vector (1+ offset)) word (nthcdr offset nv))
	 ;;;??? but isn't (car word) 0?***
	 (rplaca word (logior (car word) bits))
	 (do ((v v (cdr v)) (nv nv (cdr nv))) ((null v)) (rplaca nv (car v)))
	 nv)
	((not= 0 (logand bits (car word))) v)
	(t (rplaca word (logior (car word) bits)) v)))

;;; This version of vector-cons uses break coding.  It gets the assumption's 
;;; address and calls blist-cons.  Warning: NON DESTRUCTIVE! (Never thought I'd
;;; be writing a note like that!  The reason for this warning is that some of 
;;; the callers will be expecting this to be destructive, and they shouldn't.



;;;******* A straight call --- this function is probably unceessary.
(defun basic-make-assumption-internal-blist (count variable value datum)
  (internal-make-assumption count
			    variable
			    value
			    datum
			    'OUT
			    'DONT))

;;;********** Never called.
(defun vector-cons-blist (assumption blist)
 (cons-blist (assumption-unique assumption) blist))

;;; Bit vector hackery.

;;; Array references are just too much of a pain and inefficient.  This implementation
;;; stores them as a list of 24 bit fixnums. 

;;; Is the set described by vector v1 a subset of v2?
;;; ******* NOtice it turns into a *boole instruction, IL might be better.
(defun vector-subset-bits (v1 v2)
  (do ((v1 v1 (cdr v1))
       (v2 v2 (cdr v2)))
      ((null v1)  T)
    (if (or (null v2) (not-subset-bits (car v1) (car v2))) (return nil))))

(defun vector-subset-info-bits (v1 v2 &aux (c 0) w)
  (prog nil
	(unless v1 (return nil))
     START
	(unless v2 (go FIND-FAIL))
	(setq w (logand (car v1) (lognot (car v2))))
	(unless (zerop w) (go FAIL))
	(setq v1 (cdr v1))
	(unless v1 (return nil))
	(setq v2 (cdr v2))
	(incf c)
	(go START)
     FIND-FAIL
	;; Find first non-zero word in v1.
	(setq w (car v1))
	(when (zerop w)
	  (setq v1 (cdr v1))
	  (incf c)
	  (go FIND-FAIL))

     FAIL
	;;**** remove from here and blits some time and make it part of debug***
	(if (= w 0) (error "Not possible"))
	(dotimes (bit #.*word-size* (error "Drop through error"))
	  (unless (zerop (logand w 1))
	    (return-from vector-subset-info-bits
	      (aref *assumption-array* (+ bit (* c #.*word-size*)))))	
	  (setq w (ash w -1)))))

;;; This is like vector-subset-bits2, but
(defun vector-subset-bits2 (v1 v2 a &aux offset)
  (setq offset (assumption-offset a))
  (do ((i 0 (1+ i))
       (v1 v1 (cdr v1))
       (v2 v2 (cdr v2)))
      ((null v1) T)
    (cond ((null v2) 
	   ;; **** Could be much more efficient.
	   (cond ((< i offset) (unless (= (car v1) 0) (return nil)))
		 ((= i offset)
		  (if (cdr v1) (return nil))
		  (return (= (car v1) (assumption-bits a))))
		 ((> i offset) (return nil))))
	  ((not-subset-bits (car v1) (if (= i offset)
					 (logior (assumption-bits a) (car v2))
					 (car v2)))
	   (return nil)))))

;;; If the vectors get long, stepping with cddddr might be much more efficient.
(defun vector-member-bits (a v)
  (when v
    (do ((i (assumption-offset a) (1- i)))
	((= i 0))
      (unless (setq v (cdr v)) (return-from VECTOR-MEMBER-BITS nil)))
    (not= 0 (logand (assumption-bits a) (car v)))))

;;; This tries to do the minimum consing without clobbering anything.  This is slightly
;;; slower than previous version of vector-union-bits, but it does one heck of lot
;;; less consing.
(defun vector-union-bits (v1 v2 &aux result min same)
  ;; v1 max v2 min.
  (do ((i 0 (1+ i))
       (v1* v1 (cdr v1*))
       (v2* v2 (cdr v2*)))
      (nil)
    (cond ((null v1*) (if (null v2*) (setq same T min i) (psetq min i v1 v2 v2 v1))
	   (return nil))
	  ((null v2*) (setq min i) (return nil))))
  (cond ((= min 0) nil)
	((= min 1) (if same (list (logior (car v1) (car v2)))
		            (cons (logior (car v1) (car v2)) (cdr v1))))
	((= min 2) (if same (list (logior (car v1) (car v2))
				  (logior (cadr v1) (cadr v2)))
		            (list* (logior (car v1) (car v2))
				   (logior (cadr v1) (cadr v2))
				   (cddr v1))))
	(t (setq result (simple-make-list #+Symbolics (if same min (1+ min))
					  #-Symbolics min
					  0))
	   (do ((result result (cdr result))
		(v1 v1 (cdr v1))
		(v2 v2 (cdr v2)))
	       (nil)
	     (rplaca result (logior (car v1) (car v2)))
	     (when (null (cdr v2))
	       (if same (return nil))
	       #-Symbolics (rplacd result (cdr v1))
	       #+Symbolics (rplaca (cdr result) (cdr v1))
	       #+Symbolics (sys:%p-dpb sys:cdr-normal sys:%%q-cdr-code result)
	       (return nil)))
	   result)))

;;; Can be made more efficient.
(defun vector-union-unsafe-bits (v1 v2 conses &aux result min end new same)
  (macrolet ((cons (a b) `(cons-unsafe ,a ,b))
	     (push (a b) `(push-unsafe ,a ,b))
	     (list (a &optional b) (if b `(cons-unsafe ,a (cons-unsafe ,b nil))
				       `(cons-unsafe ,a nil)))
	     (list* (a b c) `(cons-unsafe ,a (cons-unsafe ,b ,c))))
    ;; v1 max v2 min.
    (do ((i 0 (1+ i))
	 (v1* v1 (cdr v1*))
	 (v2* v2 (cdr v2*)))
	(nil)
      (cond ((null v1*) (if (null v2*) (setq same T min i) (psetq min i v1 v2 v2 v1))
	     (return nil))
	    ((null v2*) (setq min i) (return nil))))
    (cond ((= min 0) (setq result v1))
	  ((= min 1) (setq result (if same (list (logior (car v1) (car v2)))
				      (cons (logior (car v1) (car v2)) (cdr v1)))))
	  ((= min 2) (setq result
			   (if same (list (logior (car v1) (car v2))
					  (logior (cadr v1) (cadr v2)))
			       (list* (logior (car v1) (car v2))
				      (logior (cadr v1) (cadr v2))
				      (cddr v1)))))
	  (t (do ((v1 v1 (cdr v1))
		  (v2 v2 (cdr v2)))
		 (nil)
	       (setq new (cons (logior (car v1) (car v2)) nil))
	       (if end (rplacd end new) (setq result new))
	       (setq end new)
	       (when (null (cdr v2))
		 (rplacd end (cdr v1))
		 (return nil)))))
  (values result conses)
  ))

;;; The short cases arise often enough to be worth optimizing.  This now cdr-codes.
;;; This *must* return 100% fresh structure.
(defun vector-union-new-bits (v1 v2 &aux result min max)
  ;; Make v1 max v2 min.
  (do ((i 0 (1+ i))
       (v1* v1 (cdr v1*))
       (v2* v2 (cdr v2*)))
      ((null (or v1* v2*)) (setq max i))
    (cond (min)
	  ((null v1*) (psetq v1* v2* v2* v1* v1 v2 v2 v1) (setq min i))
	  ((null v2*) (setq min i))))
  (unless min (setq min max))
  (cond ((= min 0) (fcopylist v1))
	((= min 1) (setq v1 (fcopylist v1))
	           (rplaca v1 (logior (car v1) (car v2)))
		   v1)
	((= min max 2)
	 (list (logior (car v1) (car v2)) 
	       (logior (cadr v1) (cadr v2))))
	(t (setq result (simple-make-list max 0))
	   (do ((result result (cdr result))
		(v1 v1 (cdr v1))
		(v2 v2 (cdr v2)))
	       ((null result))
	     (rplaca result
		     (cond ((null v1) (car v2))
			   ((null v2) (car v1))
			   (t (logior (car v1) (car v2))))))
	   result)))

;;; This clobbers its first argument.  Do we want to cons are not???? I don't think so?
(defun vector-union-old-bits (v1 v2 &aux result)
  (setq result v1)
  (do ((old-v1 nil v1)
       (v1 v1 (cdr v1))
       (v2 v2 (cdr v2)))
      ((null v2) result)
    (unless v1
      (return (cond (old-v1 (rplacd old-v1 (fcopylist v2)) result)
		    (t (fcopylist v2)))))
    (rplaca v1 (logior (car v1) (car v2)))))

;;; This doesn't alter its arguments, but does reuse them.  No attempt to cdr code.
(defun vector-andc2-bits (v1 v2 &aux result)
  (do ((v1 v1 (cdr v1))
       (v2 v2 (cdr v2)))
      (nil)
    (if v1
	(if v2
	    (push (logandc2 (car v1) (car v2)) result)
	    (return (nreconc result v1)))
	(return (nreconc result v2)))))

;;; This can be considerably optimized.
(defun remove-assumption-bits (vector assumption &aux word)
  (setq vector (fcopylist vector)
	word (nthcdr (assumption-offset assumption) vector))
  (cond (word (rplaca word (logandc2 (car word) (assumption-bits assumption)))
	      ;; ***** Can be optimized by sanitizing.
	      (sanitize-vector vector))
	(t vector))
  vector)

(defun vector-xor-unions (xor unions &aux result word word1)
  (if *break-coded* (error "Unimplemented"))
  (setq unions (fcopylist unions))
  (do ((xor xor (cdr xor)))
      (nil)
    (setq word 0 word1 nil)
    (do ((unions unions (cdr unions)))
	((null unions))
      (when (setq word1 (caar unions))
	(setq word (logior word word1))
	(rplaca unions (cdar unions))))
    (and (null xor) (null word1) (return))
    (if xor (setq word (logand (lognot (car xor)) word)))
    (push word result))
  (nreverse result))

;;; This is passed a set of pairs (on off) and returns a cdr coded list.  I'm
;;; not sure whether that is a good idea or not...
;;; Word-end is the absolute position at which the current word ends.
;;; Make more efficient****
(defun construct-vector-run-bits (&rest runs &aux vector word word-end)
  (setq vector (make-bit-vector (1+ (floor (1- (car (last runs))) #.*word-size*)))
	word vector
	word-end #.*word-size*)
  (do ((runs runs (cddr runs)))
      ((null runs))
    ;; Do an nth-cdr?
    (do nil ((< (car runs) word-end))
      (incf word-end #.*word-size*)
      (setq word (cdr word)))
    ;; This is inefficient as hell.
    (do ((i (car runs) (1+ i)))
	((= i (cadr runs)))
      (unless (< i word-end)
	(incf word-end #.*word-size*)
	(setq word (cdr word)))
      (rplaca word (set-bit (car word) (- (+ i #.*word-size*) word-end)))))
  vector)

;;; Returns T if the two vectors have a non-empty intersections.
;;; Note that this is identical to vector-subset (paramaterized).
(defun vector-intersection-bits? (v1 v2)
  (do ((v1 v1 (cdr v1))
       (v2 v2 (cdr v2)))
      ((or (null v1) (null v2)) nil)
    (unless (zerop (logand (car v1) (car v2))) (return T))))

;;; This gives you the size of the union without having to cons it up!.
;;; This is as slow as a dog and should not be used.
(defun vector-union-size-bits (v1 v2 &aux (size 0) r)
  (do ((v1 v1 (cdr v1))
       (v2 v2 (cdr v2)))
      (nil)
    (cond (v1 (cond (v2 (setq r (logior (car v1) (car v2)))
			(unless (= r 0) (incf size (logcount r))))
		    (t (dolist (v1 v1 (cdr v1))
			 (unless (= v1 0) (incf size (logcount v1))))
		       (return nil))))
	  (v2 (dolist (v2 v2 (cdr v2))
		(unless (= v2 0) (incf size (logcount v2))))
	      (return nil))
	  (t (return nil))))
  size)

;;; This specifically ignores the indicated bit position, whether or not it
;;; lies in the intersection.
(defun vector-intersection-bits2? (v1 v2 a &aux offset)
  (setq offset (assumption-offset a))
  (do ((i 0 (1+ i))
       (v1 v1 (cdr v1))
       (v2 v2 (cdr v2)))
      ((or (null v1) (null v2)) nil)
    (unless (zerop (if (= i offset)
		       (logand (car v1) (car v2) (lognot (assumption-bits a)))
		       (logand (car v1) (car v2))))
      (return T))))

;;; ***** this can be optimized a lot.
(defun vector-complement (v)
  (if *break-coded* (error "Unimplemented"))
  (setq v (fcopylist v))
  (do ((v v (cdr v)))
      ((null v))
    (rplaca v (lognot (car v))))
  (sanitize-vector v))

;;; Converts a vector into an ordered list of assumptions using array.  Ignores bits
;;; past end.  Stupid.
;;; A list of masks would be faster also.
#-:IL
(defun vector-assumptions (v array &aux assumptions (offset 0))
  (if *break-coded* (error "Unimplemented"))
  (dolist (word v)
    (unless (= word 0)
      (dotimes (bit #.*word-size*)
	(unless (zerop (logand word 1)) (push (aref array (+ offset bit)) assumptions))
	(setq word (ash word -1))))
    (incf offset #.*word-size*))
  (nreverse assumptions))

#-:IL
(defun nvector-assumptions (v array &aux assumptions (offset 0) end p)
  (if *break-coded* (error "Unimplemented"))
  (setq end (array-length array))
  (dolist (word v)
    (unless (= word 0)
      (dotimes (bit #.*word-size*)
	(when (zerop (logand word 1))
	  (setq p (+ offset bit))
	  (if ( p end) (return nil))
	  (push (aref array p) assumptions))
	(setq word (ash word -1))))
    (incf offset #.*word-size*))
  (nreverse assumptions))

(defun nmap-assumptions-bits (vector function &aux (offset 0) p)
  #+Symbolics
  (declare (sys:downward-funarg function))
  (dolist (word vector)
    (unless (= word 0)
      (dotimes (bit #.*word-size*)
	(unless (zerop (logand word 1))
	  (setq p (+ offset bit))
	  (if (> p *assumption-counter*) (return-from NMAP-ASSUMPTIONS-BITS nil))
	  (funcall function (aref *assumption-array* p)))
	(setq word (ash word -1))))
    (incf offset #.*word-size*)))

(defun nnvector-assumptions-bits (vector &aux assumptions (offset 0) p)
  (dolist (word vector)
    (unless (= word 0)
      (dotimes (bit #.*word-size*)
	(unless (zerop (logand word 1))
	  (setq p (+ offset bit))
	  (if (> p *assumption-counter*) (return-from NNVECTOR-ASSUMPTIONS-BITS assumptions))
	  (push (aref *assumption-array* p) assumptions))
	(setq word (ash word -1))))
    (incf offset #.*word-size*))
  assumptions)

;;; If vectors are presumed to be bits here, then not vector-subset.
(defun vector-simplify (l)
  (if *break-coded* (error "Unimplemented"))
  (setq l (mapcar #'(lambda (vector) (cons (length vector) vector)) l)
	l (sort l #'(lambda (v1 v2) (< (car v1) (car v2))))
	l (mapcan #'(lambda (vector) (rplaca vector (cdr vector))
			             (rplacd vector nil))
		  l))
  (do ((l l (cdr l)))
      ((null l))
    (do ((l2 (cdr l) (cdr l2)))
	((null l2))
      (and (car l) (car l2) (vector-subset (car l) (car l2)) (rplaca l2 nil))))
  (setq l (fdelqa nil l)))

;;;***** the * functions are temp kludges.
(defun cons-blist* (assumption vector) (cons-blist (assumption-unique assumption) vector))

(defun vector-cons4-bits* (assumption vector)
  (vector-cons4-bits (assumption-offset assumption) (assumption-bits assumption) vector))

;;; Like vector-intersection2? but ignores the presumed intersecting specified bit.
(defun blintersection2?* (v1 v2 a) (blintersection2? v1 v2 (assumption-unique a)))

;;; Turn a bl into a set of assumptions.
(defun nnvector-assumptions-bl (vector &aux assumptions)
  (do ((vector vector (cddr vector)))
      ((null vector))
    (do ((i (car vector) (1+ i))
	 (end (cadr vector)))
	((= i end))
      (push (aref *assumption-array* i) assumptions)))
  assumptions)

(defun nmap-assumptions-bl (vector function)
  #+Symbolics
  (declare (sys:downward-funarg function))
  (do ((vector vector (cddr vector)))
      ((null vector))
    (do ((i (car vector) (1+ i))
	 (end (cadr vector)))
	((= i end))
      (funcall function (aref *assumption-array* i)))))

(defun make-env-blist* (assumptions &optional ignore) (make-env-blist assumptions))

;;;*** clean up some day, to avoid the nested calls.
(defun install-break ()
  (setq *break-coded* T)
  (setf (symbol-function 'vector-subset-info) #'error)
  (setf (symbol-function 'vector-equal) #'vector-equal-bits)
  (setf (symbol-function 'nmap-assumptions) #'nmap-assumptions-bl)
  (setf (symbol-function 'nnvector-assumptions) #'nnvector-assumptions-bl)
  (setf (symbol-function 'vector-cons4) #'cons-blist*)
  (setf (symbol-function 'vector-intersection2?) #'blintersection2?*)
  (setf (symbol-function 'vector-intersection?) #'blintersection?)
  (setf (symbol-function 'vector-subset) #'blsubset)
  (setf (symbol-function 'vector-subset2) #'error)
  (setf (symbol-function 'vector-union) #'blor)
  (setf (symbol-function 'vector-union-new) #'blor-new)
  (setf (symbol-function 'vector-union-old) #'blor-old)
  (setf (symbol-function 'make-env-vector) #'make-env-blist*)
  (setf (symbol-function 'vector-member)
	#'(lambda (assumption vector)
	    (vector-member-blist? (assumption-unique assumption) vector)))
  (setf (symbol-function 'make-env-vector*) #'make-env-blist)
  (setf (symbol-function 'vector-cons1)
	#'(lambda (assumption vector)
	    ;;***** efficient version of this someday?
	    ;;******* maybe cons-blist does this anyway?
	    (if (vector-member-blist? (assumption-unique assumption) vector)
		vector
		(cons-blist (assumption-unique assumption) vector))))
  (setf (symbol-function 'vector-cons3)
	#'(lambda (assumption vector)
	    (dcons-blist (assumption-unique assumption) vector)))
  (setf (symbol-function 'basic-make-assumption-internal)
	#'basic-make-assumption-internal-blist)
  (setf (symbol-function 'construct-vector-run) #'vector-run-blist)
  #-Symbolics
  (format T "~% Warning, you need to write a decent hash function (blhash) for your machine.")
  (setf (symbol-function 'hash) #'blhash)
  (setf (symbol-function 'vector-andc2) #'error)
  (setf (symbol-function 'remove-assumption) #'remove-assumption-blist)
  )

(defun install-bits ()
  (setq *break-coded* nil)
  (setf (symbol-function 'vector-union-unsafe) #'vector-union-unsafe-bits)
  (setf (symbol-function 'vector-subset-info) #'vector-subset-info-bits)
  (setf (symbol-function 'vector-equal) #'vector-equal-bits)
  (setf (symbol-function 'nmap-assumptions) #'nmap-assumptions-bits)
  (setf (symbol-function 'nnvector-assumptions) #'nnvector-assumptions-bits)
  (setf (symbol-function 'vector-cons4) #'vector-cons4-bits*)
  (setf (symbol-function 'vector-intersection2?) #'vector-intersection-bits2?)
  (setf (symbol-function 'vector-intersection?) #'vector-intersection-bits?)
  (setf (symbol-function 'vector-subset2) #'vector-subset-bits2)
  (setf (symbol-function 'vector-subset) #'vector-subset-bits)
  (setf (symbol-function 'vector-union) #'vector-union-bits)
  (setf (symbol-function 'vector-union-new) #'vector-union-new-bits)
  (setf (symbol-function 'vector-union-old) #'vector-union-old-bits)
  (setf (symbol-function 'make-env-vector) #'make-env-vector-bits)
  (setf (symbol-function 'vector-member) #'vector-member-bits)
  (setf (symbol-function 'make-env-vector*) #'make-env-vector-bits*)
  (setf (symbol-function 'vector-cons1) #'vector-cons1-bits)
  (setf (symbol-function 'vector-cons3) #'vector-cons3-bits)
  (setf (symbol-function 'basic-make-assumption-internal)
	#'basic-make-assumption-internal-bits)
  (setf (symbol-function 'construct-vector-run) #'construct-vector-run-bits)
  (setf (symbol-function 'hash) #'hash-bits)
  (setf (symbol-function 'vector-andc2) #'vector-andc2-bits)
  (setf (symbol-function 'remove-assumption) #'remove-assumption-bits)
  )

;;;***** above is a bit of a crock because the compiler is not smart enoough
;;; to not turn them into lexical closures.

(defun install ()
  (if *break-coded* (install-break) (install-bits)))

(install)