anchor.diff:      (setf nodes (nconc nodes (list node)))))
   
   (defun merge-text-blocks (block1 block2)
  -  (with-slots ((pos1 offset) (blocks1 blocks)) block1
  -    (with-slots ((pos2 offset) (blocks2 blocks)) 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 blocks1 block2)))))
  +                     :nodes (nconc nodes1 nodes2)))))
   
   (defun document->text-blocks (document)
  -  (let* ((text-blocks '()))
  -
  -    (labels ((find-text-blocks (node)
  -               (let ((children (stp:list-children node)))
  -                 (if (or (heading? node)
  -                         (every (lambda (node)
  -                                  (typecase node
  -                                    (stp:text t)
  -                                    (stp:element
  -                                     (inline? (stp:local-name node)))))
  -                                children))
  -                     (push (prog1 node (stp:detach node)) text-blocks)
  -                     (mapc #'find-text-blocks children)))))
  -      (mapc #'find-text-blocks (stp:list-children (car (css:query "body" document)))))
  -
  -    (proximity-fusion (simple-fusion (nreverse text-blocks)))))
  -
  -(defun delete-blanks (blocks)
  -  (delete-if (lambda (item)
  -               (and (typep item 'stp:text)
  -                    (every #'whitespacep (stp:data item))))
  -             blocks))
  -
  -(defun simple-fusion (blocks)
  +  (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 y)
  -     (cond ((not y)
  -            (cons x y))
  -           ;; TODO block proximity fusion
  -           ((= (text-density x)
  -               (text-density (car y)))
  -            (cons (fuse-blocks x (car y))
  -                  (cdr y)))
  -           (t (cons x y))))
  +   (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 proximity-fusion (blocks)
  +(defun block-proximity-fusion (blocks)
     (reduce
      (lambda (x ys)
  -     (if (not ys)
  -         (cons x ys)
  -         (destructuring-bind (y . ys) ys
  -           (cond ((or (and (typep x 'stp:text)
  -                           (typep y 'stp:text)))
  -                  (cons (stp:make-text
  -                         (format nil "~a ~a"
  -                                 (stp:data x)
  -                                 (stp:data y)))
  -                        ys))
  -                 ((and (or (typep x 'stp:text)
  -                           (inline? (stp:local-name x)))
  -                       (or (typep y 'stp:text)
  -                           (inline? (stp:local-name y))))
  -                  (cons (fuse-blocks x y) ys))
  -                 (t (list* x y 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 fuse-blocks (x y)
  -  (make-text-block
  -   (append (fusibles x)
  -           (fusibles y))))
  -
  -(defun make-text-block (elements)
  -  (let ((tb (stp:make-element "span")))
  -    (setf (stp:attribute-value tb "class") "text-block")
  -    (dolist (e elements)
  -      (stp:detach e)
  -      (stp:append-child tb e))
  -    tb))
  -
  -(defun fusibles (element)
  -  (if (text-block? element)
  -      (stp:list-children element)
  -      (list element)))
  -
  -(defun text-block? (element)
  -  (and (typep element 'stp:element)
  -       (equal (stp:local-name element) "span")
  -       (equal (stp:attribute-value element "class") "text-block")))
  -
  -(defun inline? (lname)
  -  (find lname
  -        '("a" "strike" "u" "b" "i" "em" "strong" "span" "sup" "code" "tt" "sub" "var"
  -          "abbr" "acronym" "font")
  -        :test 'equalp))
  -
  -(defun heading? (lname)
  -  (find lname '("li" "h1" "h2" "h3")
  -        :test 'equal))
  +(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))
  
positive.code:                 :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 text-length (node)
    (typecase node
  
negative.code:      (reduce #'+ (stp:list-children node) :key #'text-length))
      (t 0)))
  
  (defun compute-text-density (nodes &key (width 80))
    (let ((col 0)
          (lines -1)
          (words 0))
      ;; A restrictive idea of words.
      (labels ((process-text (text)
                 (ppcre:do-scans (start end rs re "[a-zA-Z0-9]+" text)
                   (incf words)
                   (let ((len (- end start)))
                     (when (> (incf col len) width)
                       (incf lines 1)
                       (setf col len)))))
               (process-node (node)
                 (typecase node
                   (stp:text (process-text (stp:data node)))
                   (stp:element
                    (stp:do-recursively (n node)
                      (when (typep n 'stp:text)
                        (process-text (stp:data n))))))))
  
        (dolist (node nodes)
          (process-node node)))
  
      (/ words (float (max 1 lines)))))
  