Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv9434

Modified Files: message-display.lisp beirc.lisp Log Message: Switched time-stamps to right-hand column. Better wrapping of message column.

Date: Fri Sep 23 11:52:41 2005 Author: dmurray

Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.3 beirc/message-display.lisp:1.4 --- beirc/message-display.lisp:1.3 Sun Sep 18 00:34:00 2005 +++ beirc/message-display.lisp Fri Sep 23 11:52:40 2005 @@ -1,7 +1,7 @@ (in-package :beirc)

(defparameter *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/") -(defparameter *default-fill-column* 100) +(defparameter *default-fill-column* 80)

(defvar *max-preamble-length* 0)

@@ -16,6 +16,15 @@ *hyperspec-base-url* (subseq url (+ 45 start))) 'url)) + ((> (length url) *default-fill-column*) + (let ((new-url + (concatenate 'string + (subseq url 0 (floor *default-fill-column* 2)) + "..." + (subseq url (- (length url) + (- (floor *default-fill-column* 2) 3)))))) + (with-output-as-presentation (t url 'url) + (write-string new-url)))) (t (present url 'url)))))

(defun message-from-focused-nick-p (message receiver) @@ -47,48 +56,49 @@ *max-preamble-length*) :cache-test #'equal) (formatting-row (,stream*) - (formatting-cell (,stream* :align-x :left) - (format ,stream* "~&[~2,'0D:~2,'0D] " - (nth-value 2 (decode-universal-time (irc:received-time message))) - (nth-value 1 (decode-universal-time (irc:received-time message))))) - (formatting-cell (,stream* :align-x :right) - (with-drawing-options (*standard-output* :ink +dark-red+) + (formatting-cell (,stream* :align-x :right :min-width '(16 :character)) + (with-drawing-options (,stream* :ink +dark-red+) ,@preamble-column-body)) - (formatting-cell (,stream* :align-x :left) - ,@message-body-column-body)))))) + (formatting-cell (,stream* :align-x :left + :min-width '(80 :character)) + ,@message-body-column-body) + (formatting-cell (,stream* :align-x :left) + (with-drawing-options (,stream* :ink +gray+) + (format ,stream* "[~2,'0D:~2,'0D]" + (nth-value 2 (decode-universal-time (irc:received-time message))) + (nth-value 1 (decode-universal-time (irc:received-time message)))))))))))

(defun strip-punctuation (word) (if (= (length word) 0) (values word "") (let ((last-char (char word (1- (length word))))) (case last-char - ((#: #, #. #;) + ((#: #, #. #; #) #] #} #> #? #! #" #') (values (subseq word 0 (1- (length word))) (string last-char))) (otherwise (values word ""))))))

-(defun format-message* (mumble &key (limit *default-fill-column*)) +(defun format-message* (mumble &key (limit *default-fill-column*) (start-length 0)) (loop for (word . rest) on (split-sequence:split-sequence #\Space mumble) - with column = 0 - with column-limit = limit - do (multiple-value-bind (word* stripped-punctuation) (strip-punctuation word) - (cond - ((search "http://" word*) - (present-url word*)) - ((or - (nick-equals-my-nick-p word*) - (irc:find-user (current-connection *application-frame*) word*)) - (present word* 'nickname)) - (t (write-string word*))) - (write-string stripped-punctuation)) - ;; TODO: nick highlighting via presentations - (incf column (length word)) - when (> column column-limit) - do (setf column 0) - (terpri) - else unless (null rest) - do (write-char #\Space) - (incf column)) + with column = start-length + do (incf column (length word)) + when (> column limit) + do (setf column (length word)) + (terpri) + do (multiple-value-bind (word* stripped-punctuation) (strip-punctuation word) + (cond + ((search "http://" word*) + (present-url word*)) + ((or + (nick-equals-my-nick-p word*) + (irc:find-user (current-connection *application-frame*) word*)) + (present word* 'nickname)) + (t (write-string word*))) + (write-string stripped-punctuation)) + ;; TODO: more highlighting + unless (or (null rest) (>= column limit)) + do (write-char #\Space) + (incf column)) (terpri))

(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) @@ -114,20 +124,21 @@ ((format t "*")) ((present source 'nickname) (format t " ") - (format-message* matter))))) + (format-message* matter :start-length (+ 2 (length source)))))))

(defmethod print-message ((message irc:irc-quit-message) receiver) (formatting-message (t message receiver) - ((format t "***")) + ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format t "Quit: ") (present (irc:source message) 'nickname) (format t ": ") - (format-message* (irc:trailing-argument message)))))) + (format-message* (irc:trailing-argument message) + :start-length (+ 8 (length (irc:source message))))))))

(defmethod print-message ((message irc:irc-join-message) receiver) (formatting-message (t message receiver) - ((format t "***")) + ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format t "Join: ") (present (irc:source message) 'nickname) @@ -135,7 +146,7 @@

(defmethod print-message ((message irc:irc-nick-message) receiver) (formatting-message (t message receiver) - ((format t "***")) + ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format t "Nick change: ") (present (irc:source message) 'nickname) @@ -144,7 +155,7 @@

(defmethod print-message ((message irc:irc-part-message) receiver) (formatting-message (t message receiver) - ((format t "***")) + ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format t "Part: ") (present (irc:source message) 'nickname)

Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.12 beirc/beirc.lisp:1.13 --- beirc/beirc.lisp:1.12 Sun Sep 18 00:34:00 2005 +++ beirc/beirc.lisp Fri Sep 23 11:52:40 2005 @@ -407,7 +407,7 @@

(define-presentation-method present (o (type nickname) *standard-output* (view textual-view) &key) (if (nick-equals-my-nick-p o) - (with-drawing-options (t :ink +green+) + (with-drawing-options (t :ink +darkgreen+) (with-text-face (t :bold) (format t "~A" o))) (format t "~A" o)))