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>
Every KOM client needs color model conversion code:
......
......@@ -597,17 +597,20 @@ Otherwise treat \\ in NEWTEXT string as special:
;;; ================================================================
;;; Color stuff
(defun lyskom-color-values (color &optional frame)
(defun lyskom-color-values (color)
nil)
(eval-and-compile
(cond ((fboundp 'color-values) (fset 'lyskom-color-values 'color-values))
((fboundp 'x-color-values) (fset 'lyskom-color-values 'x-color-values))
((fboundp 'make-specifier)
(defun lyskom-color-values (color &optional frame)
(let ((spec (make-specifier 'color)))
(set-specifier spec color)
(color-rgb-components spec))))))
((and (fboundp 'color-rgb-components)
(fboundp 'make-specifier))
(defun lyskom-color-values (color)
(when (stringp color)
(let ((spec nil))
(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)
(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 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 c") 'kom-who-is-on-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
(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 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 m") 'kom-who-is-on-in-conference)
(define-key lyskom-sv-mode-map (kbd "v n") 'kom-who-is-present-in-conference)
......
......@@ -858,6 +858,9 @@ for strings."
;;; Faces
;;;
(make-face 'lyskom-weak-highlight-face)
(make-face 'lyskom-strong-highlight-face)
(defun lyskom-set-face-foreground (face color)
(condition-case nil
(set-face-foreground face color)
......@@ -877,26 +880,47 @@ for strings."
(defun lyskom-set-face-scheme (scheme)
"Set the LysKOM color and face scheme to SCHEME. Valid schemes are listed
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
(fboundp 'copy-face)
(fboundp 'lyskom-set-face-foreground)
(fboundp 'lyskom-set-face-background))
(mapcar
(lambda (spec)
(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))))
(cdr tmp)))))
;; If we have a background color, then compute the highlight colors
(when background
(lyskom-set-face-background 'lyskom-strong-highlight-face
(lyskom-get-color-highlight (lyskom-color-values background) 0.05))
(lyskom-set-face-background 'lyskom-weak-highlight-face
(lyskom-get-color-highlight (lyskom-color-values background) 0.025)))
;; 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)
(if (eq (lyskom-emacs-version) 'xemacs)
;; XEmac style
;; XEmacs style
(let ((val (x-get-resource (concat face-name ".attribute" attr)
(concat "Face.Attribute" attr)
type)))
......@@ -934,23 +958,20 @@ also reads the proper X resources."
(error 'default))))
(lyskom-set-face-scheme kom-default-face-scheme)
(if (eq (console-type) 'x)
(mapcar
(function
(lambda (face)
(let* ((face-name (symbol-name face))
(fg (lyskom-face-resource face-name "Foreground" 'string))
(bg (lyskom-face-resource face-name "Background" 'string))
(bl (lyskom-face-resource face-name "Bold" 'boolean))
(it (lyskom-face-resource face-name "Italic" 'boolean))
(ul (lyskom-face-resource face-name "Underline" 'boolean)))
(if fg (set-face-foreground face fg))
(if bg (set-face-background face bg))
(if (eq bl 'on) (lyskom-modify-face 'bold face))
(if (eq bl 'off) (lyskom-modify-face 'unbold face))
(if (eq it 'on) (lyskom-modify-face 'italic face))
(if (eq it 'off) (lyskom-modify-face 'unitalic face))
(if ul (set-face-underline-p face (eq ul 'on))))))
lyskom-faces)))
(lyskom-traverse face lyskom-faces
(let* ((face-name (symbol-name face))
(fg (lyskom-face-resource face-name "Foreground" 'string))
(bg (lyskom-face-resource face-name "Background" 'string))
(bl (lyskom-face-resource face-name "Bold" 'boolean))
(it (lyskom-face-resource face-name "Italic" 'boolean))
(ul (lyskom-face-resource face-name "Underline" 'boolean)))
(if fg (set-face-foreground face fg))
(if bg (set-face-background face bg))
(if (eq bl 'on) (lyskom-modify-face 'bold face))
(if (eq bl 'off) (lyskom-modify-face 'unbold face))
(if (eq it 'on) (lyskom-modify-face 'italic face))
(if (eq it 'off) (lyskom-modify-face 'unitalic face))
(if ul (set-face-underline-p face (eq ul 'on)))))))
;;; ============================================================
......@@ -1432,14 +1453,15 @@ in the 20th century")
(defun lyskom-get-color-highlight (color distance)
"Create a highlight color for COLOR that is DISTANCE away.
COLOR is a string naming the color and DISTANCE is a non-negative
integer no larger than 255, that in some way specifies how far
away from the original color the new color should be."
(let* ((hls (lyskom-rgb-to-hls (lyskom-string-to-rgb color)))
COLOR is a list of R G and B components from 0 to 65535.
DISTANCE is a non-negative integer no larger than 1.0, that in some
way specifies how far away from the original color the new color
should be."
(let* ((hls (lyskom-rgb-to-hls (mapcar (lambda (x) (/ x 65535.0)) color)))
(l (elt hls 1)))
(if (> l 0.6)
(setq l (- l (/ distance 255.0)))
(setq l (+ l (/ distance 255.0))))
(setq l (- l distance))
(setq l (+ l distance)))
(cond ((> l 1.0) (setq l 1.0))
((< l 0.0) (setq l 0.0)))
(aset hls 1 l)
......@@ -1555,50 +1577,50 @@ has the bug in that algorithm fixed)."
;;; (setq g (+ g step)))
;;; (setq r (+ r step)))))
;;; (defun lyskom-test-auto-colors ()
;;; (make-face 'test-1)
;;; (make-face 'test-2)
;;; (make-face 'test-default)
;;; (while t
;;; (let ((foreground (read-from-minibuffer "Foreground: "))
;;; (background (read-from-minibuffer "Background: ")))
;;; (pop-to-buffer (get-buffer-create "*kom*-test"))
;;; (erase-buffer)
;;; (set-face-foreground 'test-default foreground)
;;; (set-face-background 'test-default background)
;;; (set-face-background 'test-1 (lyskom-get-color-highlight background 16))
;;; (set-face-background 'test-2 (lyskom-get-color-highlight background 8))
;;; (let ((lyskom-buffer (current-buffer)))
;;; (lyskom-format-insert "\
;;; %#3@Lsa nsta fotnot...
;;; 8408827 idag 00:40 /1 rad/ Lunkwill/CH ( Auf das Universum! )
;;; Fotnot till text 8408825 av Lunkwill/CH ( Auf das Universum! )
;;; Mottagare: Ntverk, Internet, LysNET, Sunet... <30873>
;;; Mottagare: SUBnet (Stngstadens och LiU:s) studentbostadsnt <12152>
;;; Mottagare: Lunkwill/CH ( Auf das Universum! ) <2092>
;;; rende: Vrmtet
;;; %[%#1$------------------------------------------------------------
;;; %]%[%#2$Och tack s mycket fr frklaringarna! =)
;;; %]%[%#1$(8408827) /Lunkwill/CH ( Auf das Universum! )/------
;;; %]G till nsta mte...
;;; SUN erfarenhetsutbyte - 1 olst
;;; Lsa nsta text...
;;; 8408823 idag 00:39 /4 rader/ Erik Persson, Lysato(r)
;;; Kommentar till text 8407161 av Dejan (ngot desperat)
;;; Mottagare: SUN erfarenhetsutbyte <23622>
;;; rende: Skapa partitionstabell
;;; %[%#1$------------------------------------------------------------
;;; %]%[%#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
;;; sett ngon som stdjer ngot annat n FC-AL vilket r lite
;;; begrnsande.
;;; %]%[%#1$(8408823) ------------------------------------------
;;; %]G till nsta mte...
;;;
;;;
;;;
;;; "
;;; '(face test-1)
;;; '(face test-2)
;;; '(face test-default))))))
;;;(defun lyskom-test-auto-colors ()
;;; (make-face 'test-1)
;;; (make-face 'test-2)
;;; (make-face 'test-default)
;;; (while t
;;; (let ((foreground (read-from-minibuffer "Foreground: "))
;;; (background (read-from-minibuffer "Background: ")))
;;; (pop-to-buffer (get-buffer-create "*kom*-test"))
;;; (erase-buffer)
;;; (set-face-foreground 'test-default foreground)
;;; (set-face-background 'test-default background)
;;; (set-face-background 'test-1 (lyskom-get-color-highlight (x-color-values background) 0.05))
;;; (set-face-background 'test-2 (lyskom-get-color-highlight (x-color-values background) 0.025))
;;; (let ((lyskom-buffer (current-buffer)))
;;; (lyskom-format-insert "\
;;;%#3@Lsa nsta fotnot...
;;;8408827 idag 00:40 /1 rad/ Lunkwill/CH ( Auf das Universum! )
;;;Fotnot till text 8408825 av Lunkwill/CH ( Auf das Universum! )
;;;Mottagare: Ntverk, Internet, LysNET, Sunet... <30873>
;;;Mottagare: SUBnet (Stngstadens och LiU:s) studentbostadsnt <12152>
;;;Mottagare: Lunkwill/CH ( Auf das Universum! ) <2092>
;;;rende: Vrmtet
;;;%[%#1$------------------------------------------------------------
;;;%]%[%#2$Och tack s mycket fr frklaringarna! =)
;;;%]%[%#1$(8408827) /Lunkwill/CH ( Auf das Universum! )/------
;;;%]G till nsta mte...
;;;SUN erfarenhetsutbyte - 1 olst
;;;Lsa nsta text...
;;;8408823 idag 00:39 /4 rader/ Erik Persson, Lysato(r)
;;;Kommentar till text 8407161 av Dejan (ngot desperat)
;;;Mottagare: SUN erfarenhetsutbyte <23622>
;;;rende: Skapa partitionstabell
;;;%[%#1$------------------------------------------------------------
;;;%]%[%#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
;;;sett ngon som stdjer ngot annat n FC-AL vilket r lite
;;;begrnsande.
;;;%]%[%#1$(8408823) ------------------------------------------
;;;%]G till nsta mte...
;;;
;;;
;;;
;;;"
;;; '(face test-1)
;;; '(face test-2)
;;; '(face test-default))))))
;;;
......@@ -2925,6 +2925,7 @@ the value of kom-tell-phrases for fun.")
(kom-first-line-face bold nil nil)
(kom-dim-face default "gray" nil)
(kom-dashed-lines-face nil nil "#e8e8ff")
(property expected-background "white")
)
(bark
(kom-active-face default "Gold" "Black")
......@@ -2943,6 +2944,7 @@ the value of kom-tell-phrases for fun.")
(kom-friends-face nil "Gold" "Black")
(kom-morons-face nil "Gold" "Black")
(kom-warning-face bold "Red" nil)
(property expected-background "black")
)
(black-and-tan
(kom-text-body-face nil nil "#f8f8f0")
......@@ -2961,6 +2963,7 @@ the value of kom-tell-phrases for fun.")
(kom-first-line-face bold nil nil)
(kom-dim-face default "gray" nil)
(kom-dashed-lines-face nil nil "#f0f0e0")
(property expected-background "white")
)
(inverse
(kom-text-body-face nil nil "#080808")
......@@ -2979,6 +2982,7 @@ the value of kom-tell-phrases for fun.")
(kom-first-line-face nil nil "black")
(kom-dim-face default "gray" nil)
(kom-dashed-lines-face nil nil black)
(property expected-background "black")
)
(monochrome
(kom-text-body-face nil nil nil)
......@@ -2997,6 +3001,7 @@ the value of kom-tell-phrases for fun.")
(kom-warning-face bold nil nil)
(kom-first-line-face bold nil nil)
(kom-dim-face default nil nil)
(property expected-background "white")
)
(minimal
(kom-text-body-face nil nil nil)
......@@ -3015,6 +3020,7 @@ the value of kom-tell-phrases for fun.")
(kom-first-line-face nil nil nil)
(kom-dashed-lines-face nil nil nil)
(kom-dim-face default nil nil)
(property expected-background "white")
)
(highlight
(kom-text-body-face nil nil "#f8f8ff")
......@@ -3033,6 +3039,7 @@ the value of kom-tell-phrases for fun.")
(kom-first-line-face nil nil "lavender")
(kom-dashed-lines-face nil nil "lavender")
(kom-dim-face default "gray" nil)
(property expected-background "white")
))
"*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