Commit ddcde14e authored by Michael Raskin's avatar Michael Raskin

Syncing from Monotone at 20200214-024736. Last commit message was Performance and correctness fixes

parent 1d366452
......@@ -17,5 +17,5 @@ cd "$(dirname "$0")"
(or (ignore-errors
(thoughtful-theridion:html-element-to-text
(make-instance (quote thoughtful-theridion:html-textifier-protocol-inspector))
(thoughtful-theridion:parsed-content fetcher)))
fetcher))
\"\")))"
......@@ -54,11 +54,20 @@ as readable content in case this element is picked as a part of main content.
(defgeneric html-score-text (protocol text))
(defvar *unicode-property-cache* (make-hash-table :test 'equal))
(defun unicode-property-counts (text &rest properties)
(apply 'values
(loop for p in properties
collect (count-if
(lambda (x) (cl-unicode:has-property x p))
(lambda (x)
(multiple-value-bind
(value presentp)
(gethash (list x p) *unicode-property-cache*)
(if presentp value
(setf
(gethash (list x p) *unicode-property-cache*)
(cl-unicode:has-property x p)))))
text))))
(defmethod html-score-text ((protocol html-text-score-protocol) (text null)) 0)
......@@ -254,7 +263,8 @@ as readable content in case this element is picked as a part of main content.
(defmethod html-score-content-dispatch ((protocol html-classname-score-protocol)
(type (eql :element)) tag element cache)
(let* ((class-attribute (html5-parser:element-attribute element "class"))
(id (html5-parser:element-attribute element "id"))
(id (string-downcase
(html5-parser:element-attribute element "id")))
(classes (cl-ppcre:split
(format nil "[~{~a~}]+" (or *whitespace-list* (list #\Space)))
(string-downcase class-attribute)))
......@@ -280,5 +290,6 @@ as readable content in case this element is picked as a part of main content.
(cond (drop (values 0 () "" nil))
(t (multiple-value-bind (score subscores pass-text content) (call-next-method)
(let* ((boosted (+ score boost))
(pass-boosted (+ score (if (> boost 0) 0 (/ boost 2)))))
(core-score (or (car subscores) 0))
(pass-boosted (+ core-score (if (> boost 0) 0 (/ boost 2)))))
(values boosted (cons pass-boosted (cdr subscores)) pass-text content)))))))
(defpackage :thoughtful-theridion
(:use :common-lisp)
(:export
;; Fetching
#:*default-user-agent*
#:http-fetcher
#:navigate
#:submit-form
#:html-textifier-protocol
#:html-textifier-protocol-inspector
#:html-element-to-text
#:html-inner-text
#:save-web-page
#:save-web-form
;; Additional functionality for fetching
#:parsed-content
#:current-url
#:current-content
......@@ -20,10 +16,31 @@
#:parse-obtained-content
#:*base-url*
#:real-url
;; Converting HTML to text
#:html-textifier-protocol
#:html-textifier-protocol-inspector
#:html-element-to-text
#:html-inner-text
;; Generic page walking/web crawling macros
#:page-walk
#:page-walk-each
#:page-walk-each-of
#:page-walk-maybe-each-of
#:page-walk-each-of-nonempty
;; Main content extraction
#:html-score-content
#:html-score-content-dispatch
#:with-html-score-content-protocol
#:def-html-score-content
#:html-text-score-protocol
#:html-classname-score-protocol
#:html-score-text
#:html-content-score-summarize
#:collect-child-scoring-data
#:build-content-dom
#:html-extract-main-content
;; Utility functions
#:save-web-page
#:save-web-form
))
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment