car off the front of a list.(define (cover8 value->keys-table better-solution)
(define (add-v-k-entry solution-set v-k-entry)
(let ((value (car v-k-entry))
(keys (cdr v-k-entry)))
(write-string "Adding value ") (write value) (newline)
(write-string " with keys ") (write keys) (newline)
(write-string " to ") (write (length solution-set))
(write-string " partial solutions.") (newline)
(let ((new-solutions
(map make-new-solution (cartesian-product solution-set keys))))
(let ((trimmed-solutions
(trim-partial-solutions value->keys-table new-solutions)))
(write-string "Returning ") (write (length trimmed-solutions))
(write-string " of ") (write (length new-solutions))
(write-string " new partial solutions.") (newline)
trimmed-solutions))))
(define (cover v-k-entries)
(cond ((pair? v-k-entries)
(pick-v-k-entry value->keys-table v-k-entries
(lambda (selected remaining)
(add-v-k-entry (cover remaining) selected))))
((null? v-k-entries)
(list '()))
(else (improper-list-error 'cover v-k-entries))))
(let ((minimized (minimize-vktable value->keys-table better-solution)))
(least-elements (cover minimized) better-solution)))
(define (pick-v-k-entry value->keys-table v-k-entries receiver)
(define (score v-k-entry)
(let* ((matched-all
(count-matching-items value->keys-table
(lambda (other)
(there-exists? (cdr v-k-entry)
(lambda (key) (member key (cdr other)))))))
(matched-remaining
(count-matching-items v-k-entries
(lambda (other)
(there-exists? (cdr v-k-entry)
(lambda (key) (member key (cdr other)))))))
(matched-forward (- matched-all matched-remaining)))
(cons matched-remaining matched-forward)))
(let ((scored (map (lambda (v-k-entry) (cons (score v-k-entry) v-k-entry))
v-k-entries)))
(let ((picked
(cdar
(least-elements scored
(lambda (left right)
(let* ((len-l (length (cdr left)))
(len-r (length (cdr right)))
(lmr (caar left))
(lmf (cdar left))
(rmr (caar right))
(rmf (cdar right)))
(or (> len-l len-r)
(and (= len-l len-r)
(or (> lmf rmf)
(and (= lmf rmf)
(< lmr rmr)))))
))))))
(display "Picking ") (write picked) (newline)
(receiver picked (delete picked v-k-entries)))))
(define (trim-partial-solutions value->keys-table partial-solutions)
(let ((equivalent-solutions
(map (lambda (entry) (cons (cdr entry) (car entry)))
(collect-equivalent-partial-solutions value->keys-table
partial-solutions))))
(write-string " Deleting ")
(write (- (length partial-solutions) (length equivalent-solutions)))
(write-string " equivalent partial solutions.")
(newline)
(remove-dominated-solutions value->keys-table
(map lowest-scoring-equivalent-partial-solution
equivalent-solutions))))
Finally, it turns out that computing dominating partial solutions is expensive, so I changed the set operations to use a bitmap representation:(define (remove-dominated-solutions value->keys-table partial-solutions)
(let ((before-length (length partial-solutions))
(all-values (get-values value->keys-table)))
(let ((table
;; put the long ones in first
(sort
(map (lambda (partial-solution)
(cons partial-solution
(lset->bset all-values
(map car (partial-solution-matches value->keys-table
partial-solution)))))
partial-solutions)
(lambda (left right)
(> (length (bset->lset all-values (cdr left)))
(length (bset->lset all-values (cdr right))))))))
(let ((answer (map car
(fold-left (lambda (answer solution)
(if (there-exists? answer
(dominates-solution? solution))
answer
(cons solution answer)))
'()
table))))
(let ((after-length (length answer)))
(write-string " Removing ") (write (- before-length after-length))
(write-string " dominated solutions.")
(newline)
answer)))))
(define (dominates-solution? solution)
(let* ((partial-solution (car solution))
(partial-solution-score (score partial-solution))
(solution-matches-raw (cdr solution)))
(lambda (other-solution)
(let* ((other-partial-solution (car other-solution))
(other-matches-raw (cdr other-solution)))
(and
(bset-superset? other-matches-raw solution-matches-raw)
(<= (score other-partial-solution) partial-solution-score))))))
(define (get-values v-k-table)
(fold-left (lambda (answer entry) (lset-adjoin equal? answer (car entry)))
'()
v-k-table))
(define (bset-element->bit universe element)
(cond ((null? element) 0)
(else (expt 2 (list-index (lambda (item) (eq? item element)) universe)))))
(define (bset-adjoin universe bset element)
(bset-union bset (bset-element->bit universe element)))
(define (lset->bset universe lset)
(fold-left (lambda (answer element)
(bset-adjoin universe answer element))
0
lset))
(define (bset->lset universe bset)
(cond ((zero? bset) '())
((even? bset) (bset->lset (cdr universe) (/ bset 2)))
(else (cons (car universe) (bset->lset (cdr universe) (/ (- bset 1) 2))))))
(define (bset-union left right) (bitwise-ior left right))
(define (bset-superset? bigger smaller)
;; Is every element of smaller in bigger?
(zero? (bitwise-andc2 smaller bigger)))
This code can now find the shortest regular expression consisting of letters and dots (and ^$) that matches one set of strings but not another.Depending on the strings, this can take quite a bit of time to run. Dotted expressions cause a combinatorical explosion in matching regexps (or substrings), but what makes it worse is that the dotted expressions tend to span different sets of strings. If two different dotted expressions, each with different matching sets of strings, appear in a single string, then the number of partial solutions will be multiplied by two as we try each different dotted expression.
It is characteristic of NP problems that it is easy to determine if you have a good solution, but quite hard to find it among a huge number of other, poor solutions. This problem exhibits this characteristic, but there is a bit more structure in the problem that we are exploiting. The word lists are drawn from the English language. This makes some bigrams, trigrams, etc. far, far, more likely to appear than others.
Short words are much easier to process than longer ones because they simply contain fewer things to match. On the other hand, longer words tend to be dominated by shorter ones anyway.
To be continued...
No comments:
Post a Comment