From 1b56b85388def0b041710d9afcf1683412151028 Mon Sep 17 00:00:00 2001 From: saturn Date: Tue, 2 May 2023 03:30:00 -0500 Subject: [PATCH] Add per-theme gamma tweaks. --- src/fonts.lisp | 2 +- src/resources.lisp | 126 ++++++++++++++++++++++------------------- src/utils.lisp | 11 ++-- www/css/style-grey.linux.css | 2 + www/css/style-grey.mac.css | 2 + www/css/style-grey.windows.css | 2 + www/css/style-less.linux.css | 2 + www/css/style-less.mac.css | 2 + www/css/style-less.windows.css | 2 + www/theme-grey.css.php | 2 + www/theme-less.css.php | 2 + 11 files changed, 90 insertions(+), 65 deletions(-) diff --git a/src/fonts.lisp b/src/fonts.lisp index c1c283c2..22501c5b 100644 --- a/src/fonts.lisp +++ b/src/fonts.lisp @@ -31,7 +31,7 @@ (sb-ext:defglobal *fonts-redirect-thread* nil) (defun update-obormot-fonts () - (with-atomic-file-replacement (out-stream (asdf:system-relative-pathname :lw2-viewer "www/fonts.css") :element-type 'character) + (with-atomic-file-replacement (out-stream (asdf:system-relative-pathname :lw2-viewer "www/fonts.css") :if-unchanged :keep-original :element-type 'character) (iter (for uri in *obormot-fonts-stylesheet-uris*) (for response = (dex:get uri diff --git a/src/resources.lisp b/src/resources.lisp index c1fcaefe..acb75e51 100644 --- a/src/resources.lisp +++ b/src/resources.lisp @@ -1,6 +1,7 @@ (uiop:define-package #:lw2.resources (:use #:cl #:iterate #:lw2-viewer.config #:lw2.utils #:lw2.sites #:lw2.context) - (:import-from #:alexandria #:with-gensyms #:when-let #:appendf) + (:import-from #:alexandria #:with-gensyms #:once-only #:when-let #:appendf) + (:import-from #:parse-float #:parse-float) (:export #:*page-resources* #:inverted-media-query #:with-page-resources #:require-resource #:generate-versioned-link #:with-resource-bindings #:call-with-fonts-source-resources #:site-resources) (:recycle #:lw2-viewer) (:unintern #:fonts-source-resources)) @@ -170,74 +171,81 @@ t))) nil) -(defun process-css-line (in-line) - (macrolet ((override (name) - `(let ((reg-matches (nth-value 1 (ppcre:scan-to-strings ,(format nil "~A:\\s*(.*?)\\s*(?:;|\\*/|$)" name) in-line)))) - (if (>= (length reg-matches) 1) (aref reg-matches 0))))) - (let* ((invert-override (override "invert-override")) - (gamma-override (override "gamma-override")) - (backgroundp (to-boolean (ppcre:scan "background|shadow" in-line))) - (gamma (cond (gamma-override (parse-float:parse-float gamma-override :type 'double-float)) - (backgroundp 1.6d0) - (t 2.2d0)))) - (values - (format nil "--theme~A-color" - (cond (invert-override (format nil "-override-~A" (multiple-value-call #'lw2.colors::safe-color-name (lw2.colors::decode-css-color invert-override)))) - (gamma-override (format nil "-gamma-~F" gamma)) - (backgroundp "-bg") - (t ""))) - invert-override - gamma)))) +(defmacro override-scan (name in-line) + (once-only (in-line) + `(let ((reg-matches (nth-value 1 (ppcre:scan-to-strings ,(format nil "~A:\\s*(.*?)\\s*(?:;|\\*/|$)" name) ,in-line)))) + (if (>= (length reg-matches) 1) (aref reg-matches 0))))) -(defmacro with-css-lines ((line-var stream) &body body) - (with-gensyms (part-line full-line) - `(loop for ,line-var = (loop with ,full-line = nil - for ,part-line = (read-line ,stream nil) - while ,part-line - do (progn - (when (not ,part-line) - (return ,full-line)) - (setf ,full-line (concatenate 'string ,full-line (string #\Newline) ,part-line)) - (when (ppcre:scan "[;{}]\\s*$" ,part-line) - (return ,full-line)))) - while ,line-var - do (locally ,@body)))) +(defun process-css-line (in-line default-gamma default-background-gamma) + (let* ((invert-override (override-scan "invert-override" in-line)) + (gamma-override (override-scan "gamma-override" in-line)) + (backgroundp (to-boolean (ppcre:scan "background|shadow" in-line))) + (gamma (cond (gamma-override (parse-float gamma-override :type 'double-float)) + (backgroundp default-background-gamma) + (t default-gamma)))) + (values + (format nil "--theme~A-color" + (cond (invert-override (format nil "-override-~A" (multiple-value-call #'lw2.colors::safe-color-name (lw2.colors::decode-css-color invert-override)))) + (gamma-override (format nil "-gamma-~F" gamma)) + (backgroundp "-bg") + (t ""))) + invert-override + gamma))) + +(defmacro with-css-lines ((line-var stream &rest vars) &body body) + (with-gensyms (default-gamma default-background-gamma part-line full-line) + `(let ((,default-gamma 2.2d0) + (,default-background-gamma 1.8d0)) + (loop for ,line-var = (loop with ,full-line = nil + for ,part-line = (read-line ,stream nil) + while ,part-line + do (progn + (when (not ,part-line) + (return ,full-line)) + (when-let ((x (override-scan "default-gamma" ,part-line))) + (setf ,default-gamma (parse-float x :type 'double-float))) + (when-let ((x (override-scan "default-background-gamma" ,part-line))) + (setf ,default-background-gamma (parse-float x :type 'double-float))) + (setf ,full-line (concatenate 'string ,full-line (string #\Newline) ,part-line)) + (when (ppcre:scan "[;{}]\\s*$" ,part-line) + (return ,full-line)))) + while ,line-var + do (multiple-value-bind ,vars + (process-css-line ,line-var ,default-gamma ,default-background-gamma) + ,@body))))) (defun output-tweakable-css (file out-stream) (with-open-file (in-stream file) - (with-css-lines (in-line in-stream) - (let* ((variable-prefix (process-css-line in-line)) - (out-line (ppcre:regex-replace-all - lw2.colors::-css-color-scanner- - in-line - (lambda (target-string start end match-start match-end reg-starts reg-ends) - (declare (ignore start end reg-starts reg-ends)) - (let ((color-string (substring target-string match-start match-end))) - (format nil "var(~A-~A)" - variable-prefix - (multiple-value-call #'lw2.colors::safe-color-name (lw2.colors::decode-css-color color-string)))))))) + (with-css-lines (in-line in-stream variable-prefix) + (let ((out-line (ppcre:regex-replace-all + lw2.colors::-css-color-scanner- + in-line + (lambda (target-string start end match-start match-end reg-starts reg-ends) + (declare (ignore start end reg-starts reg-ends)) + (let ((color-string (substring target-string match-start match-end))) + (format nil "var(~A-~A)" + variable-prefix + (multiple-value-call #'lw2.colors::safe-color-name (lw2.colors::decode-css-color color-string)))))))) (write-line out-line out-stream))))) (defun output-css-colors (file out-stream invert) (let ((used-colors (make-hash-table :test 'equal))) (with-open-file (in-stream file) (format out-stream ":root {~%") - (with-css-lines (in-line in-stream) - (multiple-value-bind (variable-prefix invert-override gamma) - (process-css-line in-line) - (ppcre:do-matches-as-strings (color-string lw2.colors::-css-color-scanner- in-line) - (multiple-value-bind (r g b a) (lw2.colors::decode-css-color color-string) - (let ((color-name (format nil "~A-~A" - variable-prefix - (lw2.colors::safe-color-name r g b a)))) - (unless (gethash color-name used-colors) - (setf (gethash color-name used-colors) t) - (format out-stream "~A: ~A;~%" - color-name - (if invert - (or invert-override - (multiple-value-call #'lw2.colors::encode-css-color (lw2.colors::perceptual-invert-rgba r g b a gamma))) - color-string)))))))))) + (with-css-lines (in-line in-stream variable-prefix invert-override gamma) + (ppcre:do-matches-as-strings (color-string lw2.colors::-css-color-scanner- in-line) + (multiple-value-bind (r g b a) (lw2.colors::decode-css-color color-string) + (let ((color-name (format nil "~A-~A" + variable-prefix + (lw2.colors::safe-color-name r g b a)))) + (unless (gethash color-name used-colors) + (setf (gethash color-name used-colors) t) + (format out-stream "~A: ~A;~%" + color-name + (if invert + (or invert-override + (multiple-value-call #'lw2.colors::encode-css-color (lw2.colors::perceptual-invert-rgba r g b a gamma))) + color-string))))))))) (format out-stream "}~%")) (sb-ext:defglobal *css-generator-lock* (sb-thread:make-mutex :name "CSS generator lock")) diff --git a/src/utils.lisp b/src/utils.lisp index b335acd9..bbffd856 100644 --- a/src/utils.lisp +++ b/src/utils.lisp @@ -438,7 +438,7 @@ specified, the KEYWORD symbol with the same name as VARIABLE-NAME is used." (unless (eq b1 b2) (return nil)) (when (eq b1 nil) (return t))))))) -(defun call-with-atomic-file-replacement (fn filename open-fn) +(defun call-with-atomic-file-replacement (fn filename open-fn if-unchanged) (let* ((normal-return nil) (filename (merge-pathnames filename)) (temp-filename (make-pathname :name (concatenate 'string (pathname-name filename) ".new") @@ -449,16 +449,17 @@ specified, the KEYWORD symbol with the same name as VARIABLE-NAME is used." (setf normal-return t)) (close stream) (if (and normal-return - (or (not (probe-file filename)) + (or (not (eq if-unchanged :keep-original)) + (not (probe-file filename)) (not (file-equal filename temp-filename)))) (uiop:rename-file-overwriting-target temp-filename filename) (uiop:delete-file-if-exists temp-filename))))) -(defmacro with-atomic-file-replacement ((stream filename &rest open-options) &body body) +(defmacro with-atomic-file-replacement ((stream filename &rest open-options &key if-unchanged &allow-other-keys) &body body) (with-gensyms (body-fn open-fn) - `(dynamic-flet ((,open-fn (filename) (open filename :direction :output :if-exists :supersede ,@open-options)) + `(dynamic-flet ((,open-fn (filename) (open filename :direction :output :if-exists :supersede :allow-other-keys t ,@open-options)) (,body-fn (,stream) ,@body)) - (call-with-atomic-file-replacement #',body-fn ,filename #',open-fn)))) + (call-with-atomic-file-replacement #',body-fn ,filename #',open-fn ,if-unchanged)))) (defun random-string (length) (let ((string (make-array length :element-type 'character :initial-element #\Space))) diff --git a/www/css/style-grey.linux.css b/www/css/style-grey.linux.css index ee508fa3..33029997 100644 --- a/www/css/style-grey.linux.css +++ b/www/css/style-grey.linux.css @@ -6158,6 +6158,8 @@ a.comment-parent-link::after { /* GREY THEME */ /**************/ +/* default-background-gamma: 2.2 */ + /*===========*/ /* VARIABLES */ /*===========*/ diff --git a/www/css/style-grey.mac.css b/www/css/style-grey.mac.css index 5954c774..e57f993e 100644 --- a/www/css/style-grey.mac.css +++ b/www/css/style-grey.mac.css @@ -6158,6 +6158,8 @@ a.comment-parent-link::after { /* GREY THEME */ /**************/ +/* default-background-gamma: 2.2 */ + /*===========*/ /* VARIABLES */ /*===========*/ diff --git a/www/css/style-grey.windows.css b/www/css/style-grey.windows.css index 9f8137fd..a2333875 100644 --- a/www/css/style-grey.windows.css +++ b/www/css/style-grey.windows.css @@ -6158,6 +6158,8 @@ a.comment-parent-link::after { /* GREY THEME */ /**************/ +/* default-background-gamma: 2.2 */ + /*===========*/ /* VARIABLES */ /*===========*/ diff --git a/www/css/style-less.linux.css b/www/css/style-less.linux.css index 3d84be22..b13cd60a 100644 --- a/www/css/style-less.linux.css +++ b/www/css/style-less.linux.css @@ -6158,6 +6158,8 @@ a.comment-parent-link::after { /* THEME LESS */ /**************/ +/* default-background-gamma: 2.2 */ + /*===========*/ /* VARIABLES */ /*===========*/ diff --git a/www/css/style-less.mac.css b/www/css/style-less.mac.css index b20ffa53..fffcea0a 100644 --- a/www/css/style-less.mac.css +++ b/www/css/style-less.mac.css @@ -6158,6 +6158,8 @@ a.comment-parent-link::after { /* THEME LESS */ /**************/ +/* default-background-gamma: 2.2 */ + /*===========*/ /* VARIABLES */ /*===========*/ diff --git a/www/css/style-less.windows.css b/www/css/style-less.windows.css index 3d84be22..b13cd60a 100644 --- a/www/css/style-less.windows.css +++ b/www/css/style-less.windows.css @@ -6158,6 +6158,8 @@ a.comment-parent-link::after { /* THEME LESS */ /**************/ +/* default-background-gamma: 2.2 */ + /*===========*/ /* VARIABLES */ /*===========*/ diff --git a/www/theme-grey.css.php b/www/theme-grey.css.php index 60a63533..41eab339 100644 --- a/www/theme-grey.css.php +++ b/www/theme-grey.css.php @@ -10,6 +10,8 @@ /* GREY THEME */ /**************/ +/* default-background-gamma: 2.2 */ + /*===========*/ /* VARIABLES */ /*===========*/ diff --git a/www/theme-less.css.php b/www/theme-less.css.php index c72a544d..6555ee28 100644 --- a/www/theme-less.css.php +++ b/www/theme-less.css.php @@ -10,6 +10,8 @@ /* THEME LESS */ /**************/ +/* default-background-gamma: 2.2 */ + /*===========*/ /* VARIABLES */ /*===========*/ -- 2.11.4.GIT