Commit 43d0037b authored by David Byers's avatar David Byers
Browse files

Implement automatic color selection for highlight faces.

Added key bindings forkom-filter-subject.
parent 191f96cd
2002-05-08 David Byers <david.byers@swipnet.se>
Automatic color selection for highlight colors:
* compatibility.el (lyskom-color-values): Smarter definition that
can handle both strings and specifiers in XEmacs.
* vars.el.in (lyskom-face-schemes): Added incredibly ugly hack to
put properties in lyskom-face-schemes.
* utilities.el (lyskom-get-color-highlight): Modified to take list
of RGB and distance from 0 to 1.
Bug 525:
* swedish-strings.el (lyskom-sv-mode-map): Bind fm till
kom-filter-recipient.
* english-strings.el (lyskom-en-mode-map): Bind fr till
kom-filter-recipient.
2002-05-07 David Byers <david.byers@swipnet.se> 2002-05-07 David Byers <david.byers@swipnet.se>
Every KOM client needs color model conversion code: Every KOM client needs color model conversion code:
......
...@@ -597,17 +597,20 @@ Otherwise treat \\ in NEWTEXT string as special: ...@@ -597,17 +597,20 @@ Otherwise treat \\ in NEWTEXT string as special:
;;; ================================================================ ;;; ================================================================
;;; Color stuff ;;; Color stuff
(defun lyskom-color-values (color &optional frame) (defun lyskom-color-values (color)
nil) nil)
(eval-and-compile (eval-and-compile
(cond ((fboundp 'color-values) (fset 'lyskom-color-values 'color-values)) (cond ((fboundp 'color-values) (fset 'lyskom-color-values 'color-values))
((fboundp 'x-color-values) (fset 'lyskom-color-values 'x-color-values)) ((and (fboundp 'color-rgb-components)
((fboundp 'make-specifier) (fboundp 'make-specifier))
(defun lyskom-color-values (color &optional frame) (defun lyskom-color-values (color)
(let ((spec (make-specifier 'color))) (when (stringp color)
(set-specifier spec color) (let ((spec nil))
(color-rgb-components spec)))))) (set-specifier (setq spec (make-specifier 'color)) color)
(setq color spec)))
(color-rgb-components color)))
((fboundp 'x-color-values) (fset 'lyskom-color-values 'x-color-values))))
;;; ====================================================================== ;;; ======================================================================
......
...@@ -2222,6 +2222,7 @@ Number of sessions: %21#1d (total) ...@@ -2222,6 +2222,7 @@ Number of sessions: %21#1d (total)
(define-key lyskom-en-mode-map (kbd "f s") 'kom-filter-subject) (define-key lyskom-en-mode-map (kbd "f s") 'kom-filter-subject)
(define-key lyskom-en-mode-map (kbd "f a") 'kom-filter-author) (define-key lyskom-en-mode-map (kbd "f a") 'kom-filter-author)
(define-key lyskom-en-mode-map (kbd "f c") 'kom-filter-text) (define-key lyskom-en-mode-map (kbd "f c") 'kom-filter-text)
(define-key lyskom-en-mode-map (kbd "f r") 'kom-filter-recipient)
(define-key lyskom-en-mode-map (kbd "w w") 'kom-who-is-on) (define-key lyskom-en-mode-map (kbd "w w") 'kom-who-is-on)
(define-key lyskom-en-mode-map (kbd "w c") 'kom-who-is-on-in-conference) (define-key lyskom-en-mode-map (kbd "w c") 'kom-who-is-on-in-conference)
(define-key lyskom-en-mode-map (kbd "w p") 'kom-who-is-present-in-conference) (define-key lyskom-en-mode-map (kbd "w p") 'kom-who-is-present-in-conference)
......
...@@ -2682,6 +2682,7 @@ Visar vilka som f ...@@ -2682,6 +2682,7 @@ Visar vilka som f
(define-key lyskom-sv-mode-map (kbd "f [") 'kom-filter-subject) (define-key lyskom-sv-mode-map (kbd "f [") 'kom-filter-subject)
(define-key lyskom-sv-mode-map (kbd "f f") 'kom-filter-author) (define-key lyskom-sv-mode-map (kbd "f f") 'kom-filter-author)
(define-key lyskom-sv-mode-map (kbd "f i") 'kom-filter-text) (define-key lyskom-sv-mode-map (kbd "f i") 'kom-filter-text)
(define-key lyskom-sv-mode-map (kbd "f m") 'kom-filter-recipient)
(define-key lyskom-sv-mode-map (kbd "v i") 'kom-who-is-on) (define-key lyskom-sv-mode-map (kbd "v i") 'kom-who-is-on)
(define-key lyskom-sv-mode-map (kbd "v m") 'kom-who-is-on-in-conference) (define-key lyskom-sv-mode-map (kbd "v m") 'kom-who-is-on-in-conference)
(define-key lyskom-sv-mode-map (kbd "v n") 'kom-who-is-present-in-conference) (define-key lyskom-sv-mode-map (kbd "v n") 'kom-who-is-present-in-conference)
......
...@@ -858,6 +858,9 @@ for strings." ...@@ -858,6 +858,9 @@ for strings."
;;; Faces ;;; Faces
;;; ;;;
(make-face 'lyskom-weak-highlight-face)
(make-face 'lyskom-strong-highlight-face)
(defun lyskom-set-face-foreground (face color) (defun lyskom-set-face-foreground (face color)
(condition-case nil (condition-case nil
(set-face-foreground face color) (set-face-foreground face color)
...@@ -877,26 +880,47 @@ for strings." ...@@ -877,26 +880,47 @@ for strings."
(defun lyskom-set-face-scheme (scheme) (defun lyskom-set-face-scheme (scheme)
"Set the LysKOM color and face scheme to SCHEME. Valid schemes are listed "Set the LysKOM color and face scheme to SCHEME. Valid schemes are listed
in lyskom-face-schemes." in lyskom-face-schemes."
(let ((tmp (assoc scheme lyskom-face-schemes))) (let ((tmp (assoc scheme lyskom-face-schemes))
(properties nil)
(background (or (face-background 'default)
(frame-property (selected-frame) 'background-color))))
(when (and tmp (when (and tmp
(fboundp 'copy-face) (fboundp 'copy-face)
(fboundp 'lyskom-set-face-foreground) (fboundp 'lyskom-set-face-foreground)
(fboundp 'lyskom-set-face-background)) (fboundp 'lyskom-set-face-background))
(mapcar
(lambda (spec)
(if (elt spec 1) ;; If we have a background color, then compute the highlight colors
(lyskom-copy-face (elt spec 1) (elt spec 0))
(make-face (elt spec 0))) (when background
(when (elt spec 2) (lyskom-set-face-background 'lyskom-strong-highlight-face
(lyskom-set-face-foreground (elt spec 0) (elt spec 2))) (lyskom-get-color-highlight (lyskom-color-values background) 0.05))
(when (elt spec 3) (lyskom-set-face-background 'lyskom-weak-highlight-face
(lyskom-set-face-background (elt spec 0) (elt spec 3)))) (lyskom-get-color-highlight (lyskom-color-values background) 0.025)))
(cdr tmp)))))
;; Traverse face specifications in the face scheme
(lyskom-traverse spec (cdr tmp)
(if (eq 'property (car spec))
(setq properties (cons (cons (elt spec 1) (elt spec 2)) properties))
(if (elt spec 1) (lyskom-copy-face (elt spec 1) (elt spec 0)) (make-face (elt spec 0)))
(when (elt spec 2) (lyskom-set-face-foreground (elt spec 0) (elt spec 2)))
(when (elt spec 3) (lyskom-set-face-background (elt spec 0) (elt spec 3)))))
;; Check that the background color of the default face is what
;; the face scheme expects. If not, copy the computed highlight
;; faces to the real highlight faces.
(when (and background (assq 'expected-background properties))
(unless (equal (lyskom-color-values (cdr (assq 'expected-background properties)))
(lyskom-color-values background))
(copy-face 'lyskom-strong-highlight-face 'kom-dashed-lines-face)
(copy-face 'lyskom-weak-highlight-face 'kom-text-body-face))))))
(defun lyskom-face-resource (face-name attr type) (defun lyskom-face-resource (face-name attr type)
(if (eq (lyskom-emacs-version) 'xemacs) (if (eq (lyskom-emacs-version) 'xemacs)
;; XEmac style ;; XEmacs style
(let ((val (x-get-resource (concat face-name ".attribute" attr) (let ((val (x-get-resource (concat face-name ".attribute" attr)
(concat "Face.Attribute" attr) (concat "Face.Attribute" attr)
type))) type)))
...@@ -934,23 +958,20 @@ also reads the proper X resources." ...@@ -934,23 +958,20 @@ also reads the proper X resources."
(error 'default)))) (error 'default))))
(lyskom-set-face-scheme kom-default-face-scheme) (lyskom-set-face-scheme kom-default-face-scheme)
(if (eq (console-type) 'x) (if (eq (console-type) 'x)
(mapcar (lyskom-traverse face lyskom-faces
(function (let* ((face-name (symbol-name face))
(lambda (face) (fg (lyskom-face-resource face-name "Foreground" 'string))
(let* ((face-name (symbol-name face)) (bg (lyskom-face-resource face-name "Background" 'string))
(fg (lyskom-face-resource face-name "Foreground" 'string)) (bl (lyskom-face-resource face-name "Bold" 'boolean))
(bg (lyskom-face-resource face-name "Background" 'string)) (it (lyskom-face-resource face-name "Italic" 'boolean))
(bl (lyskom-face-resource face-name "Bold" 'boolean)) (ul (lyskom-face-resource face-name "Underline" 'boolean)))
(it (lyskom-face-resource face-name "Italic" 'boolean)) (if fg (set-face-foreground face fg))
(ul (lyskom-face-resource face-name "Underline" 'boolean))) (if bg (set-face-background face bg))
(if fg (set-face-foreground face fg)) (if (eq bl 'on) (lyskom-modify-face 'bold face))
(if bg (set-face-background face bg)) (if (eq bl 'off) (lyskom-modify-face 'unbold face))
(if (eq bl 'on) (lyskom-modify-face 'bold face)) (if (eq it 'on) (lyskom-modify-face 'italic face))
(if (eq bl 'off) (lyskom-modify-face 'unbold face)) (if (eq it 'off) (lyskom-modify-face 'unitalic face))
(if (eq it 'on) (lyskom-modify-face 'italic face)) (if ul (set-face-underline-p face (eq ul 'on)))))))
(if (eq it 'off) (lyskom-modify-face 'unitalic face))
(if ul (set-face-underline-p face (eq ul 'on))))))
lyskom-faces)))
;;; ============================================================ ;;; ============================================================
...@@ -1432,14 +1453,15 @@ in the 20th century") ...@@ -1432,14 +1453,15 @@ in the 20th century")
(defun lyskom-get-color-highlight (color distance) (defun lyskom-get-color-highlight (color distance)
"Create a highlight color for COLOR that is DISTANCE away. "Create a highlight color for COLOR that is DISTANCE away.
COLOR is a string naming the color and DISTANCE is a non-negative COLOR is a list of R G and B components from 0 to 65535.
integer no larger than 255, that in some way specifies how far DISTANCE is a non-negative integer no larger than 1.0, that in some
away from the original color the new color should be." way specifies how far away from the original color the new color
(let* ((hls (lyskom-rgb-to-hls (lyskom-string-to-rgb color))) should be."
(let* ((hls (lyskom-rgb-to-hls (mapcar (lambda (x) (/ x 65535.0)) color)))
(l (elt hls 1))) (l (elt hls 1)))
(if (> l 0.6) (if (> l 0.6)
(setq l (- l (/ distance 255.0))) (setq l (- l distance))
(setq l (+ l (/ distance 255.0)))) (setq l (+ l distance)))
(cond ((> l 1.0) (setq l 1.0)) (cond ((> l 1.0) (setq l 1.0))
((< l 0.0) (setq l 0.0))) ((< l 0.0) (setq l 0.0)))
(aset hls 1 l) (aset hls 1 l)
...@@ -1555,50 +1577,50 @@ has the bug in that algorithm fixed)." ...@@ -1555,50 +1577,50 @@ has the bug in that algorithm fixed)."
;;; (setq g (+ g step))) ;;; (setq g (+ g step)))
;;; (setq r (+ r step))))) ;;; (setq r (+ r step)))))
;;; (defun lyskom-test-auto-colors () ;;;(defun lyskom-test-auto-colors ()
;;; (make-face 'test-1) ;;; (make-face 'test-1)
;;; (make-face 'test-2) ;;; (make-face 'test-2)
;;; (make-face 'test-default) ;;; (make-face 'test-default)
;;; (while t ;;; (while t
;;; (let ((foreground (read-from-minibuffer "Foreground: ")) ;;; (let ((foreground (read-from-minibuffer "Foreground: "))
;;; (background (read-from-minibuffer "Background: "))) ;;; (background (read-from-minibuffer "Background: ")))
;;; (pop-to-buffer (get-buffer-create "*kom*-test")) ;;; (pop-to-buffer (get-buffer-create "*kom*-test"))
;;; (erase-buffer) ;;; (erase-buffer)
;;; (set-face-foreground 'test-default foreground) ;;; (set-face-foreground 'test-default foreground)
;;; (set-face-background 'test-default background) ;;; (set-face-background 'test-default background)
;;; (set-face-background 'test-1 (lyskom-get-color-highlight background 16)) ;;; (set-face-background 'test-1 (lyskom-get-color-highlight (x-color-values background) 0.05))
;;; (set-face-background 'test-2 (lyskom-get-color-highlight background 8)) ;;; (set-face-background 'test-2 (lyskom-get-color-highlight (x-color-values background) 0.025))
;;; (let ((lyskom-buffer (current-buffer))) ;;; (let ((lyskom-buffer (current-buffer)))
;;; (lyskom-format-insert "\ ;;; (lyskom-format-insert "\
;;; %#3@Lsa nsta fotnot... ;;;%#3@Lsa nsta fotnot...
;;; 8408827 idag 00:40 /1 rad/ Lunkwill/CH ( Auf das Universum! ) ;;;8408827 idag 00:40 /1 rad/ Lunkwill/CH ( Auf das Universum! )
;;; Fotnot till text 8408825 av Lunkwill/CH ( Auf das Universum! ) ;;;Fotnot till text 8408825 av Lunkwill/CH ( Auf das Universum! )
;;; Mottagare: Ntverk, Internet, LysNET, Sunet... <30873> ;;;Mottagare: Ntverk, Internet, LysNET, Sunet... <30873>
;;; Mottagare: SUBnet (Stngstadens och LiU:s) studentbostadsnt <12152> ;;;Mottagare: SUBnet (Stngstadens och LiU:s) studentbostadsnt <12152>
;;; Mottagare: Lunkwill/CH ( Auf das Universum! ) <2092> ;;;Mottagare: Lunkwill/CH ( Auf das Universum! ) <2092>
;;; rende: Vrmtet ;;;rende: Vrmtet
;;; %[%#1$------------------------------------------------------------ ;;;%[%#1$------------------------------------------------------------
;;; %]%[%#2$Och tack s mycket fr frklaringarna! =) ;;;%]%[%#2$Och tack s mycket fr frklaringarna! =)
;;; %]%[%#1$(8408827) /Lunkwill/CH ( Auf das Universum! )/------ ;;;%]%[%#1$(8408827) /Lunkwill/CH ( Auf das Universum! )/------
;;; %]G till nsta mte... ;;;%]G till nsta mte...
;;; SUN erfarenhetsutbyte - 1 olst ;;;SUN erfarenhetsutbyte - 1 olst
;;; Lsa nsta text... ;;;Lsa nsta text...
;;; 8408823 idag 00:39 /4 rader/ Erik Persson, Lysato(r) ;;;8408823 idag 00:39 /4 rader/ Erik Persson, Lysato(r)
;;; Kommentar till text 8407161 av Dejan (ngot desperat) ;;;Kommentar till text 8407161 av Dejan (ngot desperat)
;;; Mottagare: SUN erfarenhetsutbyte <23622> ;;;Mottagare: SUN erfarenhetsutbyte <23622>
;;; rende: Skapa partitionstabell ;;;rende: Skapa partitionstabell
;;; %[%#1$------------------------------------------------------------ ;;;%[%#1$------------------------------------------------------------
;;; %]%[%#2$Om du nu vill spela Fibre Channel med IDE-RAID s gr du ver n efter ;;;%]%[%#2$Om du nu vill spela Fibre Channel med IDE-RAID s gr du ver n efter
;;; vatten. Det finns redan IDE-RAID med FC-interface. Dock har jag inte ;;;vatten. Det finns redan IDE-RAID med FC-interface. Dock har jag inte
;;; sett ngon som stdjer ngot annat n FC-AL vilket r lite ;;;sett ngon som stdjer ngot annat n FC-AL vilket r lite
;;; begrnsande. ;;;begrnsande.
;;; %]%[%#1$(8408823) ------------------------------------------ ;;;%]%[%#1$(8408823) ------------------------------------------
;;; %]G till nsta mte... ;;;%]G till nsta mte...
;;; ;;;
;;; ;;;
;;; ;;;
;;; " ;;;"
;;; '(face test-1) ;;; '(face test-1)
;;; '(face test-2) ;;; '(face test-2)
;;; '(face test-default)))))) ;;; '(face test-default))))))
;;; ;;;
...@@ -2925,6 +2925,7 @@ the value of kom-tell-phrases for fun.") ...@@ -2925,6 +2925,7 @@ the value of kom-tell-phrases for fun.")
(kom-first-line-face bold nil nil) (kom-first-line-face bold nil nil)
(kom-dim-face default "gray" nil) (kom-dim-face default "gray" nil)
(kom-dashed-lines-face nil nil "#e8e8ff") (kom-dashed-lines-face nil nil "#e8e8ff")
(property expected-background "white")
) )
(bark (bark
(kom-active-face default "Gold" "Black") (kom-active-face default "Gold" "Black")
...@@ -2943,6 +2944,7 @@ the value of kom-tell-phrases for fun.") ...@@ -2943,6 +2944,7 @@ the value of kom-tell-phrases for fun.")
(kom-friends-face nil "Gold" "Black") (kom-friends-face nil "Gold" "Black")
(kom-morons-face nil "Gold" "Black") (kom-morons-face nil "Gold" "Black")
(kom-warning-face bold "Red" nil) (kom-warning-face bold "Red" nil)
(property expected-background "black")
) )
(black-and-tan (black-and-tan
(kom-text-body-face nil nil "#f8f8f0") (kom-text-body-face nil nil "#f8f8f0")
...@@ -2961,6 +2963,7 @@ the value of kom-tell-phrases for fun.") ...@@ -2961,6 +2963,7 @@ the value of kom-tell-phrases for fun.")
(kom-first-line-face bold nil nil) (kom-first-line-face bold nil nil)
(kom-dim-face default "gray" nil) (kom-dim-face default "gray" nil)
(kom-dashed-lines-face nil nil "#f0f0e0") (kom-dashed-lines-face nil nil "#f0f0e0")
(property expected-background "white")
) )
(inverse (inverse
(kom-text-body-face nil nil "#080808") (kom-text-body-face nil nil "#080808")
...@@ -2979,6 +2982,7 @@ the value of kom-tell-phrases for fun.") ...@@ -2979,6 +2982,7 @@ the value of kom-tell-phrases for fun.")
(kom-first-line-face nil nil "black") (kom-first-line-face nil nil "black")
(kom-dim-face default "gray" nil) (kom-dim-face default "gray" nil)
(kom-dashed-lines-face nil nil black) (kom-dashed-lines-face nil nil black)
(property expected-background "black")
) )
(monochrome (monochrome
(kom-text-body-face nil nil nil) (kom-text-body-face nil nil nil)
...@@ -2997,6 +3001,7 @@ the value of kom-tell-phrases for fun.") ...@@ -2997,6 +3001,7 @@ the value of kom-tell-phrases for fun.")
(kom-warning-face bold nil nil) (kom-warning-face bold nil nil)
(kom-first-line-face bold nil nil) (kom-first-line-face bold nil nil)
(kom-dim-face default nil nil) (kom-dim-face default nil nil)
(property expected-background "white")
) )
(minimal (minimal
(kom-text-body-face nil nil nil) (kom-text-body-face nil nil nil)
...@@ -3015,6 +3020,7 @@ the value of kom-tell-phrases for fun.") ...@@ -3015,6 +3020,7 @@ the value of kom-tell-phrases for fun.")
(kom-first-line-face nil nil nil) (kom-first-line-face nil nil nil)
(kom-dashed-lines-face nil nil nil) (kom-dashed-lines-face nil nil nil)
(kom-dim-face default nil nil) (kom-dim-face default nil nil)
(property expected-background "white")
) )
(highlight (highlight
(kom-text-body-face nil nil "#f8f8ff") (kom-text-body-face nil nil "#f8f8ff")
...@@ -3033,6 +3039,7 @@ the value of kom-tell-phrases for fun.") ...@@ -3033,6 +3039,7 @@ the value of kom-tell-phrases for fun.")
(kom-first-line-face nil nil "lavender") (kom-first-line-face nil nil "lavender")
(kom-dashed-lines-face nil nil "lavender") (kom-dashed-lines-face nil nil "lavender")
(kom-dim-face default "gray" nil) (kom-dim-face default "gray" nil)
(property expected-background "white")
)) ))
"*Face schemes for LysKOM. "*Face schemes for LysKOM.
......
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