anchor.diff:                  :content))
           :boilerplate)))
   
  -(defun link-density (node)
  -  (if (typep node 'stp:text)
  -      0
  -      (let ((len (text-length node)))
  -        (if (zerop len)
  -            0
  -            (let ((anchors (css:query "a" node)))
  -              (float
  -               (/ (reduce #'+ anchors :key #'text-length) len)))))))
  +(defun compute-link-density (nodes)
  +  (let ((len 0)
  +        (anchor-len 0))
  +
  +    (dolist (node nodes)
  +      (incf len (text-length node))
  +      (unless (typep node 'stp:text)
  +        (incf anchor-len (reduce #'+ (css:query "a" node) :key #'text-length))))
  +
  +    (if (zerop len)
  +        0
  +        (/ anchor-len (float len)))))
   
   (defun text-length (node)
     (typecase node
  
positive.code: (in-package #:cl-boilerpipe)
  
  (defparameter *empty* (stp:make-text ""))
  
  ;; Default extractor: simple-block-fusion, block-proximity-fusion,
  ;; density-rules-classifier.
  
  (defun strip-boilerplate (text)
    (let* ((document (chtml:parse text (stp:make-builder)))
           (text-blocks (document->text-blocks document))
           (ok (loop for prev = *empty* then curr
                     for (curr . rest) on text-blocks
                     for next = (if rest (first rest) *empty*)
                     for class = (classify prev curr next)
                     if (eql class :content)
                       collect curr))
           (new (let ((root (stp:make-element "div")))
                  (dolist (tb ok)
                    (stp:append-child root tb))
                  (stp:make-document root))))
      (stp:serialize new (cxml:make-string-sink))))
  
  (defclass text-block ()
    ((offset :initarg :offset)
     (nodes :initarg :nodes :accessor text-block-nodes)
     text-density link-density)
    (:default-initargs :nodes nil))
  
  (defmethod initialize-instance :after ((self text-block) &key nodes)
    (with-slots (text-density link-density) self
  
negative.code:     (setf nodes (nconc nodes (list node)))))
  
  (defun merge-text-blocks (block1 block2)
    (with-slots ((pos1 offset) (nodes1 nodes)) block1
      (with-slots ((pos2 offset) (nodes2 nodes)) block2
        (make-instance 'text-block
                       :offset (max pos1 pos2)
                       :nodes (nconc nodes1 nodes2)))))
  
  (defun document->text-blocks (document)
    (let ((text-blocks '())
          (offset -1)
          (nodes '()))
      (flet ((flush ()
               (push (make-instance 'text-block
                                    :offset (incf offset)
                                    :nodes (nreverse (shiftf nodes nil)))
                     text-blocks))
             (collect (node)
               (stp:detach node)
               (push node nodes)))
        (declare (dynamic-extent (function flush)
                                 (function collect)))
        (labels ((rec (node)
                   (let ((children (stp:list-children node)))
                     (dolist (node children)
                       (typecase node
                         (stp:text
                          (let ((data (stp:data node)))
                            (when (and (> (length data) 1)
                                       (notevery #'whitespacep data))
                              (collect node))))
                         (stp:element
                          (unless (search "comments" (stp:attribute-value node "class"))
                            (let ((class (classify-tag (stp:local-name node))))
                              (case class
                                (:ignorable)
                                (:inline
                                 (when (stp:list-children node)
                                   (collect node)))
                                (:keep (collect node))
                                (otherwise
                                 (flush)
                                 (rec node)))))))))))
          (rec (car (css:query "body" document)))))
      (nreverse (delete-if (lambda (tb) (zerop (text-density tb))) text-blocks))))
  
  (defun simple-block-fusion (blocks)
    (reduce
     (lambda (x ys)
       (match ys
         ((list* y ys)
          (if (= (text-density x)
                 (text-density y))
              (cons (merge-text-blocks x y) ys)
              (list* x y ys)))
         (otherwise (cons x ys))))
     blocks
     :initial-value nil
     :from-end t))
  
  (defun block-proximity-fusion (blocks)
    (reduce
     (lambda (x ys)
       (match ys
         ((list* y ys)
          (if (= (1+ (offset x)) (offset y))
              (cons (merge-text-blocks x y) ys)
              (list* x y ys)))))
     blocks
     :from-end t
     :initial-value nil))
  
  (defun classify-tag (lname)
    (string-case lname
      (("style" "script" "option" "object" "embed" "applet" "link")
       :ignorable)
      (("li" "h1" "h2" "h3")
       :heading)
      (("a" "strike" "u" "b" "i" "em" "strong" "span" "sup" "code" "tt" "sub" "var"
            "abbr" "acronym" "font"
            "mark" "cite" "del" "ins" "kbd" "q"
            "s" "samp")
       :inline)
      ("img" :keep)))
  
  (defun classify (prev curr next)
    (let ((curr-link-density (link-density curr))
  