[CM] immoral code

[Bill Schottstaedt]

Here's a function that makes my day!

(I didn't set out to break every rule of hypermodern programming,
but I came close anyway (I forgot to include a goto)):


(define (log-n-of n . ints)     ; bits on in exactly n of ints

  (define (log-none-of . ints)  ; bits on in none of ints
    (lognot (apply logior ints)))
  
  (define (log-all-of . ints)   ; bits on in all of ints
    (apply logand ints))
  
  (define (log-1-of . ints)     ; bits on in exactly 1 of ints
    (let ((len (length ints)))
      (cond ((= len 0) 
	     0)
	    ((= len 1) 
	     (car ints))
	    ((= len 2) 
	     (apply logxor ints))
	    ((= len 3) 
	     (logxor (apply logxor ints) (apply logand ints)))
	    (#t 
	     (do ((iors '())
		  (i 0 (+ i 1)))
		 ((= i len) (apply logior iors))
	       (let ((cur (ints i)))
		 (set! (ints i) 0)
		 (set! iors (cons (logand cur (lognot (apply logior ints))) iors))
		 (set! (ints i) cur)))))))
  
  (define (log-n-1-of . ints) ; bits on in exactly n-1 of ints
    (let ((len (length ints)))
      (cond ((= len 0) 
	     0)
	    ((= len 1) 
	     0)
	    ((= len 2) 
	     (apply logxor ints))
	    ((= len 3) 
	     (logand (lognot (apply logxor ints)) (apply logior ints)))
	    (#t 
	     (do ((iors '())
		  (i 0 (+ i 1)))
		 ((= i len) (apply logior iors))
	       (let ((cur (ints i)))
		 (set! (ints i) -1)
		 (set! iors (cons (logand (lognot cur) (apply logand ints)) iors))
		 (set! (ints i) cur)))))))

  (let ((len (length ints)))
    (cond ((= len 0)
	   (if (= n 0) -1 0))
	  
	  ((= n 0)
	   (apply log-none-of ints))
	  
	  ((= n len)
	   (apply log-all-of ints))
	  
	  ((> n len)
	   0)
	  
	  ((= n 1)
	   (apply log-1-of ints))
	  
	  ((= n (- len 1))
	   (apply log-n-1-of ints))
	  
	  ;; now n is between 2 and len-2, and len is 3 or more
	  ;;   I think it would be less inefficient here to choose either this 
	  ;;   or the n-1 case based on n <= len/2
	  (#t 
	   (do ((1s '())
		(prev ints)
		(i 0 (+ i 1)))
	       ((= i len) (apply logior 1s))
	     (let ((cur (ints i)))
	       (if (= i 0)
		   (set! 1s (cons (logand cur (apply log-n-of (- n 1) (cdr ints))) 1s))
		   (let* ((mid (cdr prev))
			  (nxt (if (= i (- len 1)) '() (cdr mid))))
		     (set! (cdr prev) nxt)
		     (set! 1s (cons (logand cur (apply log-n-of (- n 1) ints)) 1s))
		     (set! (cdr prev) mid)
		     (set! prev mid)))))))))