Implement automatic color selection for highlight faces.

Added key bindings forkom-filter-subject.

src/ChangeLog

+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:

src/compatibility.el

@@ -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))))
 
 
 ;;; ======================================================================

src/english-strings.el

@@ -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)

src/swedish-strings.el

@@ -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)

src/utilities.el

@@ -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))))))
 ;;;

src/vars.el.in

@@ -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.