;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Gnus Hateful Bastard functions
; 
; This file contains functions for spiteful curmedgeons, like me.  I
; *hate* it when I see smiley faces, stupid acronyms like LOL, too
; many exclamation points in a row, etc.  Consequently, I wrote the
; following functions to punish such bad writing by lowering scores in
; the all.SCORE file.
;
; By default, it also adds an entry to gnus-emphasis-alist to change
; the face of matching entries to black-on-black!  This is (to me)
; very humorous, making an offensive article look like some censor has
; gone through with a black marker, striking out words you don't like.
; But, of course, it may be a bit impractical.  If you don't like it,
; then comment out the (setq gnus-emphasis-alist ...) command below.
;
; To use these functions:
;
; (1) You'll want to edit hated-words to reflect your own arbitrary
; hang-ups.
;
; (2) You may want to edit your group parameters so that hateful is
; set to nil for mail groups.  After all, do you really want to
; disparage your momma when she uses emoticons?  Yeah, well, maybe,
; but maybe not.
;
; (3) By default, the new score entries go to the global score file.
; You can set global-hatred to nil to edit only the local score file.
;
; (4) Comment out the (setq gnus-emphasis-alist ...) if you don't want
; matches to be shown as black-on-black.
;
; Feel free to modify, distribute, whatever -- but I request that you
; include credit to me for any derivative work you distribute.
;
; Jesse Hughes 
; jesseh@cs.kun.nl
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require 'smiley)  


;; set hateful to nil for groups that you don't want to apply these
;; spiteful functions to.  

;; Also, you may set this to a number which acts as a multiplier.  

;; For instance, alt.folklore.urban is a wonderful group with high
;; standards for writing.  Consequently, any horrible misuse of
;; acronyms annoys me twice as much in that group as elsewhere.
;;
;; set global-hatred to nil if you want to change only the local score
;; files.
(setq hateful t
      global-hatred t)

;; hated words is a list of lists of the form (score regexp1 regexp2 ...)
;; Each time a regexp in a particular entry is matched, we change the author's
;; score by score.

;; score may be a number or a function.

;; This is my personal list of hated words.  I hate smileys, too.
(setq hated-words
      (list
       (cons -3 '("\\<LOL[OL]*\\>" "\\<ROT?FLMAO\\>" 
		  "\\<Nowww*\\>" "\\<ROFL\\>"))

       ;;; I hate smileys.  Gnus comes with an alist for recognizing
       ;;; them.  How lucky!
       (cons -1 (mapcar (lambda (x)(car x)) smiley-regexp-alist))

       ;;; Grinning idiots, Oh My God! and lame nickname for MS
       ;;; products.
       (cons -2 '("\\<<g\\(rin\\)?>\\>" "\\<OMG\\>" "\\<losedos\\>"))

       ;;; Lame, lame, lame...
       (cons -4 '("\\<ROFLOL\\>" "\\<guffaw\\>"))

       ;;; Marginally lame, so drop a point only half the time.
       (cons 'drop-half
	     '("\\<sux\\>" "\\<hehe\\>" 
			  "\\<plonk\\(ed\\)?\\>" "\\<nevermind\\>"))

       ;;; Bwahahahah is fucking lame.
       (cons -5 '("\\<[bB][wW][aA]*[ahwAHW]+\\>"))
       
       ;;; I study corecursion.  It's an uncommon word, so I thought
       ;;; I'd score "up" on it.
       (cons 1 '("corecursion"))
       
       ;;; Too damn much exclamations!!!!!! Dontcha think?????
       (cons -2 '("!!!!+" "\\?\\?\\?\\?+"))

       ;;; Lame criticism of Linux users, common on COLA
       (cons -10 '("[Ll]inuxfu\\(x\\|cks?\\)"))))

(add-hook 'gnus-article-prepare-hook 'punish-obnoxious-posters)

(defun wordify-list (l)
  (mapcar (lambda (w) (concat "\\([^a-zA-Z]\\)\\(" w "\\)\\([^a-zA-Z]\\)")) l))

(defun drop-half (&optional iterations)
; 50 times out of 100, lower the low scores by one.

; Surely there's a better way to do this.
  (if iterations
      (let ((i 1)
	    (max iterations)
	    (tot 0))
	(while (<= i max)
	  (setq tot (+ tot (drop-half)))
	  (setq i (+ i 1)))
	tot)
  (- (/ (% (random) 100) 50))))



;; Print a message on the minibuffer acknowledging your spitefulness.
;; Doesn't that feel better?
(defun acknowledge-hate (hatred hateful offendor)
  (if hateful
      (if (< 0 hatred)
	  (message "%s unsucks this much: %d." offender (- hatred))
	(if (< hatred -1)
	    (message "I spit in %s's direction %d times." offender (- hatred))
	  (message "%s sucks, but I've seen worse." offender)))
    (if (< 0 hatred)
	(let ((noun (if (< 1 hatred)
			"points"
		      "point")))
	  (message "%s is reasonably unsucky (%d %s), but I don't care." 
		   offender (- hatred) noun))
      (if (< 1 hatred)
	  (message "%s sucks %d pts., but I am at peace."
		   offender (- hatred))
	(message "%s is a bit sucky, but I don't care." 
		 offender))
	)))

;; This should be called by gnus-article-prepare-hook.
;;
;; Ideally, we would change the font of the offending words to
;; black-on-black, but I understand this is difficult.  Too bad.
(defun punish-obnoxious-posters ()
  (interactive)
  (save-excursion
    (let ((hatred (apply '+ (mapcar 'punish-word-list 
				    hated-words))))

      (save-excursion
	(set-buffer gnus-summary-buffer)
	(setq hatred (* hatred (if (numberp hateful)
				   hateful
				 1))))
      (if (not (eq hatred 0))
	  (progn
	    (set-buffer gnus-summary-buffer)
	    (let ((offender (gnus-summary-header "from")))
	      (if hateful
		  (let ((current-score-file gnus-current-score-file))

		    (if global-hatred
			;; Changing score file lifted from gnus-score.el.
			
			;; Change score file to the "all.SCORE" file.
			(gnus-score-load-file
			 ;; This is a kludge; yes...
			 (cond
			  ((eq gnus-score-find-score-files-function
			       'gnus-score-find-hierarchical)
			   (gnus-score-file-name ""))
			  ((eq gnus-score-find-score-files-function 
			       'gnus-score-find-single)
			   current-score-file)
			  (t
			   (gnus-score-file-name "all")))))

		    ;; Lower score
		    (gnus-summary-score-entry
		     "from"
		     offender
		     's
		     hatred
		     (current-time-string)
		     nil nil)

		    ;; Change back to old score file
		    (if global-hatred
			(gnus-score-load-file current-score-file))))
	  (acknowledge-hate hatred hateful offender)))
      ))))

;; l should be a list (score regexp regexp ...), that is, an element
;; of hated-words.  
(defun punish-word-list (l)
  (article-goto-body)     
  
  (let* ((beg (point))
	 (punishment 0)
	 (pain (car l))
	 (words (cdr l))

	 ;;Check for the signature.  I found that I kept punishing
	 ;;myself because I have a quote in my .sig containing the
	 ;;hated word "LOL".  Since I'm not really so full of
	 ;;self-loathing, I decided to omit the signature from the
	 ;;regexp search.

	 (limit (re-search-forward "^-- $" nil t))
	 (offenses (apply '+ 
			  (mapcar (lambda (x)
				    (goto-char beg)
				    (punish-word x limit))
				  words))))
    (if (numberp pain)
	(* offenses pain)
      (apply pain (list offenses))
      )))

;; Check for a single word.

(defun punish-word (w limit)
  (let ((num 0))
    (while (re-search-forward w limit t)
      (goto-char (match-beginning 0))

      ;; Skip cited lines, since quoted material isn't the poster's
      ;; fault.

      (if (not (gnus-cited-line-p))
	  (setq num (+ 1 num)))
      (goto-char (match-end 0)))
    num))

(defun make-big-regexp-of-hated-words (&optional re l)
  (if l
      (if (and (numberp (caar l))
	       (< 0 (caar l)))
	  ;; Don't black out words with positive score!
	  (make-big-regexp-of-hated-words re (cdr l))
	(if (string= re "")
	    (make-big-regexp-of-hated-words
	     (make-big-regexp-of-list (cdar l))
	     (cdr l))
	  (make-big-regexp-of-hated-words
	   (concat re
		   "\\|"
		   (make-big-regexp-of-list (cdar l)))
	   (cdr l))))
    (if re
	re
      (make-big-regexp-of-hated-words "" hated-words))))

(defun make-big-regexp-of-list (l)
  (if (cdr l)
	(make-big-regexp-of-list
	 (cons (concat 
		(car l)
		"\\|"
		(cadr l))
	       (cddr l)))
    (car l)))


(custom-set-faces
 '(gnus-hateful-bastard-censor ((t (:foreground "black" :background "black"))) t))
;; Comment out this next line unless you are as hateful as I am.  It
;; blacks out every regexp matching your hated list.
(setq gnus-emphasis-alist (append
				gnus-emphasis-alist
				(list
				 (list (make-big-regexp-of-hated-words)
				      0 0 'gnus-hateful-bastard-censor))))
(provide 'hateful-bastard)