;; An attempt to build a more elegant Bisect

(define (Bisect X H BNET)
  ;; Ugly transliteration of an ugly CommonLisp program:
  ;; this could be done more elegantly with a nested tail-recursion, but the
  ;; compiler is not smart enough to avoid the recursion here, so we grunge
  ;; it in terms of DO.
  (let* ((V (setdiff X H))
         (Vl (cardinality V)))
    (if (= 1 Vl)
      (list empty-set (setdiff X V) V)
      (let* ((low (truncate (* *balance* Vl)))
             (high (- Vl (if (zerop low) 1 low)))
             (middle (truncate Vl 2))
             (temp '()))
        (let 
          try-node
          ((sweep *max-sweeps*)
           (ordered-nodes (sort (list-nodes V BNET)
                                (lambda (a b)
                                  (< (bn-neighborhood-size a)
                                     (bn-neighborhood-size b)))))
           (BestA empty-set) 
           (BestB empty-set)
           (BestS empty-set)
           (best-score '()))
          (define (U-function v) 
            (union (setdiff S (BN-bit-rep v))
                   (intersection B (BN-Markov v))))
          (if (or (empty? ordered-nodes) 
                  (<= sweep 0) 
                  (and best-score (<= best-score 1)))
            (if (or (empty? BestA) (empty? BestB) (empty? BestS))
                ;; this means no acceptable bisection occurred
              (error "No acceptable bisection")
              (list BestA BestB BestS))
            (let 
              try
              ((A empty-set)
               (B (setdiff X (setq temp (make-set (car ordered-list)))))
               (S temp))
              (cond ((> (state-space-size (setdiff S H) BNET)
                        *max-state-space*)
                     ;; abandon search from this seed, but don't count as a sweep
                     (try-node sweep
                               (cdr ordered-nodes)
                               BestA
                               BestB
                               BestS
                               best-score))
                    ((<= low (cardinality A) high)
                     (let ((n-S-H (state-space-size (setdiff S H) BNET)))
                        (when (or (null? best-score)
                                  (< n-S-H best-score)
                                  (and (= n-S-H best-score)
                                       (< (abs (- (cardinality A) middle))
                                          (abs (- (cardinality BestA) middle)))))
                          (setq BestA A
                                BestB B
                                BestS S
                                best-score n-S-H))))
                    ((empty? (setdiff S H))
                     (let* ((ve (find-element-with-characteristic-value 
                                 min BN-neighborhood-size
                                 (setdiff B H)
                                 BNET)))
                       ;; ve is in B-H, so must've been in B.
                       (try A (union ve S) (setdiff B ve))))
                    (else 
                     (let* ((ve (find-element-with-characteristic-value
                                 min (lambda (v) 
                                       (state-space-size
                                        (setdiff (U-function v) H)
                                        BNET))
                                 S BNET)))
                       (try (union ve A)
                            (setdiff B (BN-Markov ve))     ;; B - (B int M(v))
                            (U-function ve)))))))))))))
                    (when (<= low (cardinality A) high)
                      (let ((n-S-H (state-space-size (setdiff S H) BNET)))
                        (when (or (null? best-score)
                                  (< n-S-H best-score)
                                  (and (= n-S-H best-score)
                                       (< (abs (- (cardinality A) middle))
                                          (abs (- (cardinality BestA) middle)))))
                          (setq BestA A
                                BestB B
                                BestS S
                                best-score n-S-H)))))
        (do* ((sweep *max-sweeps*
                     ;; count down only if SOME solution
                     ;; but also if there is already a perfect solution, stop
                     (if BestS (1- sweep) sweep))
              (ordered-nodes (sort (list-nodes V BNET)
                                   (lambda (a b)
                                     (< (bn-neighborhood-size a)
                                        (bn-neighborhood-size b))))
                             (cdr ordered-nodes)))
             ((or (empty? ordered-nodes) 
                  (<= sweep 0) 
                  (and best-score (<= best-score 1)))
              (if (or (empty? BestA) (empty? BestB) (empty? BestS))
                ;; this means no acceptable bisection occurred
                (error "No acceptable bisection"))
              (list BestA BestB BestS))
          (set! A empty-set)
          (set! S (make-set (car ordered-nodes)))
          (set! B (setdiff X S))
          (loop
            (when (empty? (setdiff S H))
              (let* ((ve (find-element-with-characteristic-value 
                          #'min #'BN-neighborhood-size
                          (setdiff B H)
                          BNET))
                     (veb (BN-bit-rep ve)))
                (setq S (union veb S))
                (setq B (setdiff B veb)) ;; ve is in B-H, so must've been in B.
                ))
            
            (let* ((ve (find-element-with-characteristic-value
                        #'min #'(lambda (v) 
                                  (state-space-size
                                   (setdiff (U-function v) H)
                                   BNET))
                        S BNET))
                   (veb (BN-bit-rep ve)))
              (psetq A (union veb A)
                     B (setdiff B (BN-Markov ve))	;; B - (B int M(v))
                     S (U-function ve))
              (when (> (state-space-size (setdiff S H) BNET)
                       *max-state-space*)
                ;; abandon search from this seed, but don't count as a sweep
                (return))
              (when (<= low (cardinality A) high)
                (let ((n-S-H (state-space-size (setdiff S H) BNET)))
                  (when (or (null? best-score)
                            (< n-S-H best-score)
                            (and (= n-S-H best-score)
                                 (< (abs (- (cardinality A) middle))
                                    (abs (- (cardinality BestA) middle)))))
                    (setq BestA A
                          BestB B
                          BestS S
                          best-score n-S-H)))))
            (when (= (cardinality A) high)
              (return))))))))