;;; -*- 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."

#| This is a boolean logic system optimized for space and time for very
large bit vectors with long runs.  Each vector is stored as a list of
integers, indicating where the breakpoints are in the sequence.  We
assume zero-origian and the initial value is zero.  So, this vector:
0111000 becomes: (1 5) and this vector: 11011101 becomes: (0 2 3 6 7 8).
Note that the end is reset to zero parity (the "8" in this example).

The operations implemented on these are:

	(blor a b) -- the the or, returns a blist.
	(bits-to-blist bitvector) -- makes '(0 1 1 1 0 0 0) into (1 5).
	(blist-to-bits blist) -- does the opposite.
	(blsubset subset mainset) -- asks if subset is a subset of mainset, return t/nil.
	(cons-blist position blist) -- sets a one into a blist.
	(dcons-env position blist) -- destructive version of above.  Note that this returns the list
		which *must* be reset by the caller into the desired place.  This is due to the fact that
		I handle nil and one-elt lists also.  This is *really* fast!
	(blintersection? blist blist) -- returns T if there is any interesection, nil otherwise.
	(blhash blist table-limit) -- Returns a hash key for this entry into the table.
        (blintersetion2? blist blist the-bit) -- Tells you if any bit besides the-bit is on.


|#

;;; This is the sllllooooww way to do parity.  NIL and T should be used (see BINVERT) in real
;;; applications where speed is important.

(defmacro invert (b)
  `(cond ((zerop ,b) 1) (t 0)))

#| PUSHV is supposed to optimize making a forward-reading list without
having to do revereses.  It expects there to be two pointers, on of
which it always pointing to the tail of the list.  The other is what
gets returned (the CDR of it, to be precise). |#

;;; Note that pushv's value should never be used; the above comment notwithstanding.

(defmacro pushv (value tracker)
  `(rplacd ,tracker (setq ,tracker (ncons ,value))))

;  `(progn (rplacd ,tracker (ncons ,value))
;          (pop ,tracker))) 

#| Turn a bit list into a blist. |#

(defvar *a-cons-cell* (cons nil nil))

(defun bits-to-blist (bits &aux (r *a-cons-cell*) e (v 0)) ; bits is a list of 1/0 values.
  (setq e r) ; e is the tracker.
  ;; Create the list.  V stores the parity.
  (do* ((b bits (cdr b))
        (c (car b) (car b))
        (p 0 (1+ p))
        )
       ((null b) (cond ((zerop v) (cdr r)) ; check parity and ...
                       (t (pushv p e) (cdr r)))) ; force it back to zero if necessary.
       (cond ((not (eq v c))
              (setq v c)
              (pushv p e)))
   )
 )

#| Turn a blist back to a bit list. Note that it can only go as far as the last blist entry
since it doesn't really know how many bits there are.  Therefore, the extra argument length is
given.  Note that length is a cardinal. Note that this may truncate, since an original vector
that ended in a one, gets blisted with the parity turned back to zero, making it convert back
to one bit longer than it went in.  This is actually okay for all computational purposes, but
might confuse someone who send an 8-bit vector in, and gets a 9-bit one back! |#

(defun blist-to-bits (blist length &aux (r *a-cons-cell*) e (v 0))
  (setq e r) ; e is the tracker.
  (do ((p 0 (1+ p)))
      ((or (= p length) (null blist)) (cdr (pad-out r e (- length p) v)))
      (cond ((eq p (car blist))
             (pushv (setq v (invert v)) e)
             (pop blist))
            (t (pushv v e)))
   ))

(defun pad-out (bit-list tracker n v)
  (dotimes (k n)
    (pushv v tracker))
  bit-list)

#| OR between BLISTs works as follows: set parity for each incoming list
(A and B get PA and PB respectively) to zero.  Find the lesser list
entry and copy its entry to the output.  Set that list's parity to one.
As long as either parity is one, simply delete list heads until both
parities are zero.  Put the thing which turned them both to zero out in
the output list and go back to the double zero parity state. When you
run out of one list, simply append the
 rest of it into what we've got so far.

Or "should" be end parity insensitive... he says!  Any way, there's no special code here to
handle end parity resetting, so we'll find out soon enough.

 |#

(defmacro binvert (v)
  `(setq ,v (not ,v)))

;;; Blor-old is permitted to recycle its first argument (we should).  But for now
;;; it takes the easy way out.
(defun blor-old (a b) (blor a b))

(defun blor (a b &aux (pa ()) (pb ()) (r *a-cons-cell*) e last)
  (setq e r) 
  (prog ()
        (go firstime) ; avoids having to put a null test on LAST in every loop.
   ;; We're here whenever both parity bits read 0.  
   bothzero
        ;; Last holds the last thing pulled from the lists down below.  When parity goes
        ;; snake-eyes (00) push the last removed entry onto the output.
        (pushv last e)
   firstime
        ;; If we're done with both zero then just copy the remainder onto the end.
        (cond ((null a) (rplacd e b) (return (cdr r)))
              ((null b) (rplacd e a) (return (cdr r)))
         )
        ;; In this condition, always copy the next input to the output and set parity.
        (cond ((< (car a) (car b))
               (pushv (car a) e)
               (pop a)
               (binvert pa))
              ((< (car b) (car a))
               (pushv (car b) e)
               (pop b)
               (binvert pb))
              (t (binvert pa)
                 (binvert pb)
                 (pushv (car b) e)
                 (pop b)
                 (pop a))
         )
   nonzero
        ;; If we're done with one one, then we have to consider the parity of
        ;; the done list to see what to do.  If the done one is 1 parity, then
        ;; just drop out since everything else will be a one.  Else, copy the
        ;; rest of the bits on the end as they appear.
        (cond ((null a) (and pa (return (cdr r))) (rplacd e b) (return (cdr r)))
              ((null b) (and pb (return (cdr r))) (rplacd e a) (return (cdr r)))
         )
        ;; In this condition, always dump the next input and adjust parity. 
        ;; Note that we have to save the thing dumped in LAST in case we go back up to the top.
        (cond ((< (car a) (car b))
               (binvert pa)
               (setq last (pop a)))
              ((< (car b) (car a))
               (binvert pb)
               (setq last (pop b)))
              (t (binvert pa)
                 (pop a)
                 (setq last (pop b))
                 (binvert pb))
         )
        ;; See where to go now.
        (or pa pb (go bothzero))
        (go nonzero)
     ))

;;; Same as blor, but guarantees unshared list structure.  This is important because
;;; the returned list is permitted to be clobbered.  If we disallow that, then blor-new
;;; might as well be blor.
(defun blor-new-1 (a b &aux (pa ()) (pb ()) (r *a-cons-cell*) e last)
  (setq e r) 
  (prog ()
        (go firstime) ; avoids having to put a null test on LAST in every loop.
   ;; We're here whenever both parity bits read 0.  
   bothzero
        ;; Last holds the last thing pulled from the lists down below.  When parity goes
        ;; snake-eyes (00) push the last removed entry onto the output.
        (pushv last e)
   firstime
        ;; If we're done with both zero then just copy the remainder onto the end.
        (cond ((null a) (rplacd e (append b nil)) (return (cdr r)))
              ((null b) (rplacd e (append a nil)) (return (cdr r)))
         )
        ;; In this condition, always copy the next input to the output and set parity.
        (cond ((< (car a) (car b))
               (pushv (car a) e)
               (pop a)
               (binvert pa))
              ((< (car b) (car a))
               (pushv (car b) e)
               (pop b)
               (binvert pb))
              (t (binvert pa)
                 (binvert pb)
                 (pushv (car b) e)
                 (pop b)
                 (pop a))
         )
   nonzero
        ;; If we're done with one one, then we have to consider the parity of
        ;; the done list to see what to do.  If the done one is 1 parity, then
        ;; just drop out since everything else will be a one.  Else, copy the
        ;; rest of the bits on the end as they appear.
        (cond ((null a) (and pa (return (cdr r))) (rplacd e (append b nil)) (return (cdr r)))
              ((null b) (and pb (return (cdr r))) (rplacd e (append a nil)) (return (cdr r)))
         )
        ;; In this condition, always dump the next input and adjust parity. 
        ;; Note that we have to save the thing dumped in LAST in case we go back up to the top.
        (cond ((< (car a) (car b))
               (binvert pa)
               (setq last (pop a)))
              ((< (car b) (car a))
               (binvert pb)
               (setq last (pop b)))
              (t (binvert pa)
                 (pop a)
                 (setq last (pop b))
                 (binvert pb))
         )
        ;; See where to go now.
        (or pa pb (go bothzero))
        (go nonzero)
     ))

;;; Same as blor, but guarantees unshared list structure.  This is important because
;;; the returned list is permitted to be clobbered.  If we disallow that, then blor-new
;;; might as well be blor.  It also purposely returns non-cdr coded lists!?

;;; This is nutso.  
(defun blor-new (a b &aux pa pb result last)
  (prog ()
        (go firstime) ; avoids having to put a null test on LAST in every loop.
   ;; We're here whenever both parity bits read 0.  
   bothzero
        ;; Last holds the last thing pulled from the lists down below.  When parity goes
        ;; snake-eyes (00) push the last removed entry onto the output.
	(push last result)
   firstime
        ;; If we're done with both zero then just copy the remainder onto the end.
        (cond ((null a) (return (nreconc result (mapcar #'(lambda (x) x) b))))
              ((null b) (return (nreconc result (mapcar #'(lambda (x) x) a))))
         )
        ;; In this condition, always copy the next input to the output and set parity.
        (cond ((< (car a) (car b))
	       (push (car a) result)
               (pop a)
               (binvert pa))
              ((< (car b) (car a))
	       (push (car b) result)
               (pop b)
               (binvert pb))
              (t (binvert pa)
                 (binvert pb)
		 (push (car b) result)
                 (pop b)
                 (pop a))
         )
   nonzero
        ;; If we're done with one one, then we have to consider the parity of
        ;; the done list to see what to do.  If the done one is 1 parity, then
        ;; just drop out since everything else will be a one.  Else, copy the
        ;; rest of the bits on the end as they appear.
	(unless a (return (nreconc result (unless pa (mapcar #'(lambda (x) x) b)))))
	(unless b (return (nreconc result (unless pb (mapcar #'(lambda (x) x) a)))))
        ;; In this condition, always dump the next input and adjust parity. 
        ;; Note that we have to save the thing dumped in LAST in case we go back up to the top.
        (cond ((< (car a) (car b))
               (binvert pa)
               (setq last (pop a)))
              ((< (car b) (car a))
               (binvert pb)
               (setq last (pop b)))
              (t (binvert pa)
                 (pop a)
                 (setq last (pop b))
                 (binvert pb))
         )
        ;; See where to go now.
        (or pa pb (go bothzero))
        (go nonzero)
     ))

;;; Testing fns.

(defun gen-random-bits (length &aux r)
  (dotimes (k length)
    (push (random 2) r))
  r)

(defun test-blor (&optional (tries 100) (length 8))
  (dotimes (k tries)
     (let ((a (gen-random-bits length))
           (b (gen-random-bits length)))
          (cond ((vector-equal (slow-or a b)
			       (blist-to-bits (blor (bits-to-blist a)
						    (bits-to-blist b)) length))
                 (print "ok"))
                (t (format t "Broke on ~A or ~A.~%" a b))))))

(defun slow-or (a b &aux r)
  (dolist (ia a)
    (push (logior ia (car b)) r)
    (setq b (cdr b)))
  (reverse r))

#| The subset operation is simpler than the or operation, but works on
the same principle, maintaining parity for each list and walking
through them, reading off the least head first.  As long as you've got
zero parity on the subset, you can ignore the mainset.  As long as
you've got one parity on the main set, you can ignore the subset.  As
soon as you've got zero on the main set, if there's anything in the
subset in the way, it's a lose.  Similarly, as soon as you've got one on
the subset, if the main set is a zero, it's a loser.  If you hity the
end of the sets and everythings okay, then we win. |#



;;; This version of blsubset assumes that lengths are always even.  Look in old
;;; file for version of blsubset which allows 1's at end.
(defun blsubset (subset mainset)
  (do nil (nil)
    (cond ((null subset) (return T))
	  ((null mainset) (return nil))
	  ((< (car subset) (car mainset)) (return nil))
	  ((< (cadr mainset) (car subset)) (setq mainset (cddr mainset)))
	  ((= (cadr mainset) (car subset)) (return nil))
	  ((<= (cadr subset) (cadr mainset)) (setq subset (cddr subset)))
	  (t (return nil)))))

;;; Testing fns.

(defun test-blsubset (&optional (tries 100) (length 8))
  (dotimes (k tries)
     (let ((subset (gen-random-bits length))
           (mainset (gen-random-bits length)))
          (cond ((vector-equal (slow-subset subset mainset)
			       (blsubset (bits-to-blist subset)
					 (bits-to-blist mainset)))
                 (print "ok"))
                (t (format t "Broke on ~A blsubset ~A.~%" subset mainset))))))

(defun slow-subset (subset mainset &aux)
  (dolist (im mainset t)
    (cond ((zerop im) (or (zerop (car subset)) (return nil))))
    (pop subset)))

#| Some ATMS-specific stuff here.  This probably shouldn't really be in here, Johan! |#

;;;********* It seems to me that make-env-blist is a bit slow.
(defun make-env-blist (assumptions &aux blist)
  (dolist (a assumptions) (setq blist (cons-blist (assumption-unique a) blist)))
  blist)

#| This guy take a position and a blist and makes a new blist that has that it set on.  It 
copies the blist as it walks over it. This is pretty hairy. Warning: When this has inserted
the new entry, it simply appends the rest of the list into the result without copying!!  Watch
out for desctrutive operations! |# 

(defun cons-blist (pos blist &aux (r *a-cons-cell*) (p ()) e p1)
  ;;  There's a major cannonicalization process needed here for contiguous bits.
  (setq p1 (1+ pos))
  (setq e r) ; r is the result.
  (prog ()
   outloop
        ;; If we hit the end of the old blist...
        (cond ((null blist)
               (cond (p ; and parity is one
                      (return (cdr r))) ; then ignore the new bit -- it's already there.
                     (t ; but if parity is zero...
                      (pushv pos e) ; insert this one...
                      (pushv p1 e) ; and reset parity after it...
                      (return (cdr r)) ; and we're done...
                       ))))
        ;; If the next item is one more than the new one...
        (cond ((eq (car blist) p1)
               (cond (p ; and parity is now one...
                      (go copy-rest)) ; ignore the new bit.
                     (t ; but if the parity is now zero...
                      (pushv pos e) ; add this bit in place...
                      (pop blist) ; dump the next one, since we're changing it here already...
                      (go copy-rest)) ; and flush out.
                   )))
        ;; If the next item is greater than the new one ... but not one greater (as per previous)...
        (cond ((> (car blist) pos)
               (cond (p ; and parity is now one...
                      (go copy-rest)) ; ignore the new bit.
                     (t ; but if the parity is now zero...
                      (pushv pos e) ; add this bit in place...
                      (pushv p1 e) ; put parity back with the next bit
; bug->               (pop blist) ; dump the next one, since we're changing it here already...
                      (go copy-rest)) ; and flush out.
                   )))
        ;; If the next item is equal to the new one...
        (cond ((eq (car blist) pos)
               (cond ((not p) ; and parity is now zero...
                      (go copy-rest)) ; ignore the new bit as it's already represented.
                     (t ; but if the parity is now one...
                      (pop blist) ; dump the next one, since we're changing parity right here...
                      (cond (blist ; if there's a break after the one we just dumped...
                             (cond ((eq p1 (car blist)) ; and it's one more then the present one...
                                    (pop blist)) ; flush it as well, since it's also subsumed...
                                   (t (pushv p1 e)) ; else put the transition back in.
                              )
                             )
                       )
                      (cond ((null blist) ; if we're NOW at the end...
                             (pushv p1 e))) ; re-add parity shift to zero.
                      (go copy-rest)) ; and put everything else on.
                  )))
        ;; else copy this to the output list and go on .. IO'm sure there's another condition here!
        (pushv (pop blist) e)
        (binvert p)
        (go outloop)
    copy-rest
;;; Used to actually copy the rest of the list.  Now just appends it.
        (rplacd e blist)
;       (dolist (b blist)
;         (pushv b e))
        (return (cdr r))
   ))

;;; Here's a destructive version. This absolutely assumes that there's already one bit in the register!
;;; Otherwise the handle will be nil and we won't be able to do this.

(defmacro pushd-before (what here last)
  `(rplacd ,last (cons ,what ,here)))

(defmacro pushd-after (what here)
  `(rplacd ,here (cons ,what (cdr ,here))))

(defmacro spliceout (here last)
  `(rplacd ,last (cdr ,here)))

#| The destructive cons-env.  Although this smashes pointers in the
blist, this returns the whole blist, and caller must reset the value
above.  This is so that we can work on nil -- not, there's no such
thing as a singleton blist because of parity downsetting to zero at tail
end. |#

;;; ***** If dcons-blist itself is going to get clobbered later, this should not call list
;;; ***** ever.
(defun dcons-blist (pos blist &aux return-me (p ()) p1 last)
 (prog ()
  (setq return-me blist) ; remember this to return it at end.
  (setq p1 (1+ pos))
  ;; All the special (nil, singleton, and head) cases are handled at the top for ease (ha!).  That way
  ;; I can use essentially the same code as cons-blist.
  (cond ((null blist) ; nothing there?
         (return (cons pos (ncons (1+ pos))))) ; this one's easy -- just make a blist.
        ((>= (car blist) pos) ; the new entry is before or same as the first.
         (cond ((eq pos (car blist)) ; same as first?
                (return blist)) ; if so, it's already set.
               ((eq p1 (car blist)) ; the current head is one greater than the current one?
                (return (cons pos (cdr blist)))) ; dump the current one and add this one... new starting 1.
               (t (return (cons pos (cons p1 blist)))) ; add a new bit before the head.
          ))
   )
  ;; Okay, we can assume that there are at least two entries, and we won't have to go before the first one.
  ;; Last hangs onto the previous cons cell so that the destructive operations work right.
  (setq last blist)  ; set the tracker
  (pop blist)
  (binvert p) ; skipping one so reset parity
  ;; Ready to roll on the desctructive blist updating.  This is just the same as cons-blist, but it
  ;; doesn't do terminal copying, it smashes things in place, and it always returns the head ptr.
   outloop
        ;; If we hit the end of the old blist...
        (cond ((null blist)
               (cond (p ; and parity is one
                      (return return-me)) ; then ignore the new bit -- it's already there.
                     (t ; but if parity is zero...
                      (pushd-before pos blist last) ; insert this one...
                      (pushd-after p1 (cdr last)) ; and reset parity after it...
                      (return return-me) ; and we're done...
                       ))))
        ;; If the next item is one more than the new one...
        (cond ((eq (car blist) p1)
               (cond (p ; and parity is now one...
                      (go copy-rest)) ; ignore the new bit.
                     (t ; but if the parity is now zero...
                      (rplaca blist pos) ; smash this value in place
                      (go copy-rest)) ; and flush out.
                   )))
        ;; If the next item is greater than the new one ... but not one greater (as per previous)...
        (cond ((> (car blist) pos)
               (cond (p ; and parity is now one...
                      (go copy-rest)) ; ignore the new bit.
                     (t ; but if the parity is now zero...
                      (pushd-before pos blist last) ; add this bit in place...
                      (pushd-before p1 blist (cdr last)) ; put parity back with the next bit
                      (go copy-rest)) ; and flush out.
                   )))
        ;; If the next item is equal to the new one...
        (cond ((eq (car blist) pos)
               (cond ((not p) ; and parity is now zero...
                      (go copy-rest)) ; ignore the new bit as it's already represented.
                     (t ; but if the parity is now one...
                      (spliceout blist last) ; dump the next one, since we're changing parity right here...
                      (cond ((cdr last) ; if there's a break after the one we just dumped...
                             (cond ((eq p1 (cadr last)) ; and it's one more then the present one...
                                    (rplacd last (cddr last))) ; flush it also, since it's also subsumed...
                                   (t (pushd-after p1 last)) ; else put the transition back in.
                              )
                             )
                       )
                      (pop blist)
                      (cond ((null blist) ; if we're NOW at the end...
                             (rplacd last (ncons p1)))) ; re-add parity shift to zero.
                      (go copy-rest)) ; and put everything else on.
                  )))
        ;; move on .. IO'm sure there's another condition here!
        (setq last blist)
        (pop blist)
        (binvert p)
        (go outloop)
    copy-rest ; not done in the desctructive version...just return
        (return return-me)
   ))

;;; And some test fns.

(defun slow-cons-bitvec (pos bitvec length &aux fill n) 
  (setq fill (copy-list '(0)))
  (cond ((> length (length bitvec))
         ;; N is needed due to breakage in the commonlisp compiler for D-Machines
         (setq n (- length (length bitvec)))
         (dotimes (x n)
	             (setq bitvec (append bitvec fill)))))
  (setf (nth pos bitvec) 1) bitvec)

(defun test-cons (&optional (tries 100) (maxlength 8) &aux oldbitvec smashedold r x)
  (dotimes (k tries)
     (let* ((length (random maxlength))
	    (bitvec (gen-random-bits length))
	    (pos (random maxlength)))
       (setq oldbitvec (copy-list bitvec))
       (setq smashedold (bits-to-blist (copy-list bitvec)))
       (cond ((vector-equal (slow-cons-bitvec pos bitvec maxlength)
			    (setq r (blist-to-bits
				      (setq x (dcons-blist pos (bits-to-blist bitvec))) 
				      maxlength)))
	         (format t "Ok: ~A consed into ~A -> ~A.~%" pos oldbitvec r))
	        (t (format t "Broke on ~A cons ~A/~A -> ~A/~A.~%" pos oldbitvec smashedold r x))))))

(defun fast-conser (n r)
  (declare (special b))
  (setq b ())
  (dotimes (k n) (setq b (dcons-blist (random r) b)))
 )

;;; Blist intersection is modelled after blist subset.  If the vector intersection is nil it
;;; returns nil, else (there's an intersection) returns T.

(defun blintersection? (v1 v2 &aux p1 p2 n1 n2)
  (cond ((null v1) nil)
	((null v2) nil)
	(t (prog ()
		 (setq n1 (car v1) n2 (car v2))
	      strip
		 (cond ((= n1 n2)
			(or p1 p2 (return T))
			(setq v1 (cdr v1))
			(or v1 (return nil))
			(setq n1 (car v1))
			(setq v2 (cdr v2))
			(or v2 (return nil))
			(setq n2 (car v2))
			(binvert p1)
			(binvert p2))
		       ((< n1 n2)
			(or p1 (not p2) (return t))
			(setq v1 (cdr v1))
			(or v1 (return nil))
			(setq n1 (car v1))
			(binvert p1))
		       (t
			(or p2 (not p1) (return t))
			(setq v2 (cdr v2))
			(or v2 (return nil))
			(setq n2 (car v2))
			(binvert p2))
		       )
		 (go strip)
		 ))))

;;; Testing fns.

(defun test-blintersection? (&optional (tries 100) (length 8))
  (dotimes (k tries)
     (let ((v1 (gen-random-bits length))
           (v2 (gen-random-bits length)))
          (cond ((vector-equal (slow-intersection v1 v2)
			       (blintersection? (bits-to-blist v1)
						(bits-to-blist v2)))
                 (print "ok"))
                (t (format t "Broke on ~A intersection ~A.~%" v1 v2))))))

(defun slow-intersection (v1 v2 &aux)
  (dolist (im v2 ())
    (cond ((= 1 (logand im (car v1))) (return t)))
    (pop v1)))

;;; Blist intersection with a special alternate bit arg.  The last arg (the-bit) is 
;;; assumed to already be an intersecting point.  This code checks to see if any bit
;;; *besides* the-bit is intersecting in this pair.

;;; OH SHIT.  This turns out to be more trouble than I thought.  I have to 
;;; keep track of where I actually am all the damned time!

;;; If need be this can be further optimized because the last setqs need only be done if
;;; parity is about to be set to T.

;;; This function ASSUMES that the-bit is on in the intersection, otherwise major
;;; error results.

(defun blintersection2? (v1 v2 the-bit &aux p1 p2 start)
  (prog ()
   strip
              ;; If we run out of either list, then the intersection is nil.
        (cond ((or (null v1) (null v2)) (return nil)) 
              ;; If both are equal, pop and switch parity on both.
              ((= (car v1) (car v2))
	       (setq start v1)
               (pop v1) (pop v2)
               (binvert p1) (binvert p2))
              ;; Find the nearest one, pop it and switch parities.
              ((< (car v1) (car v2))
	       (setq start v1)
	       (pop v1)
               (binvert p1))
              ((< (car v2) (car v1))
	       (setq start v2)
	       (pop v2)
               (binvert p2))
         )
        ;; If both are one then there's an intersection!
        (and p1 p2 (go gotone))
        (go strip)
   gotone
	(unless the-bit (return T))
	(unless (= (car start) the-bit) (return T))
	(if (and (< (1+ the-bit) (car v2)) (< (1+ the-bit) (car v1))) (return T))
	(setq the-bit nil)
    ))

#| Several different hashing algorithms have been tried here.  This one
rotates an integer until all the blist elements have been used and the
signb bit has been set in the integer.  We rotate one bit at a time and
each time we xor the next entry into the value.  If we run out of blist
entires before the sign bit has been set, we start over.  If we set the
sign bit before the entries run out, we go until we're out of entries.
It's possible that this can loop out if the sign bit never gets set, so
there's an arbitrary limit.  If we run out the limit before the sign bit
is set, and we've already gone around the blist once, then stop.  The
result gets modulo'ed into a table address. |#

;;; FOO!!! There are no rotation operations in commonlisp!!  What a crock!!  Well, so much for that idea!!
;;; For now we just add up the integers and take modulo table-top.

;(defun blhash-1 (blist table-top &aux (i 0) (limit 16) circled-once? sign-set?)
;  (mod (apply #'+ blist) table-top))

;;; This hash function is very bad.
#-Symbolics
(defun blhash (blist size &aux sum)
  (setq sum (car blist))
  (dolist (item (cdr blist)) (incf sum item))
  (rem sum size))

(defun blhash-3 (blist) (apply #'+ blist))

;;; This hash function is best for the symbolics machine.
;;; 1.0 - 2 - 16.8
#+Symbolics
(defun blhash (vector size &aux hash)
  (setq hash (or (car vector) 0))
  (dolist (break (cdr vector))
    (setq hash (zl:%32-bit-plus (zl:rot hash 5) break)))
  (rem (zl:%logldb (byte 31. 0) hash) size))

;; See if a particular bit is on.
(defun vector-member-blist? (pos blist &aux (p nil))
  (dolist (n blist)
    (if (< n pos) (binvert p) (return (if (= n pos) (not p) p)))))

;;; This presumes clobbering will happen.  Is there some way to construct
;;; a non-compact list?
;;; ****** some day to the experiment whether nreverse is slower than rplacd'ing.
(defun vector-run-blist (&rest blist &aux result)
  (dolist (number blist) (push number result))
  (nreverse result))

;;; Can be made more efficient.  Screws up cdr coding badly *****
(defun remove-assumption-blist (blist assumption &aux unique end-of-run)
  (setq unique (assumption-unique assumption)
	blist (fcopylist blist))
  (do ((previous nil t0)
       (t1 blist (cdr t0))
       (t0 (cdr blist) (cddr t0)))
      ((null t0 ) blist)
    ;; We are looking at a transition to 1 now.
    (cond ;; If we're past our assumption, it wasn't there.  Just return.
	  ((> (car t1) unique) (return blist))
	  ;; We've found our assumption!
	  ((= (car t1) unique)
	   (cond ;; If the 1 was a singleton.
		 ((= (car t0) (1+ unique))
		  (if previous (rplacd previous (cdr t0))
		               (setq blist (cddr blist))))
		 ;; If the 1 was first in the run, its easy.
		 (t (rplaca t1 (1+ unique))))
	   (return blist))
	  ;; If the 1 is not within the run, go on to the next run.
	  ((not (< unique (car t0))))
	  ;; If the 1 is at the end of the run things are easy.
	  ((= (1- (car t0)) unique)
	   (rplaca t0 unique)
	   (return blist))
	  ;; Else the 1 is in the middle of the run.
	  (t (setq end-of-run (car t0))
	     (rplaca t0 unique)
	     (rplacd t0 (cons (1+ unique) (cons end-of-run (cdr t0))))
	     (return blist)))))