;; The awesome lispbot... 
;; By Peter Amstutz (tetron of EFNet #lisp and #c)
;; amstpi@freenet.tlh.fl.us
;;
;; mucho thanks to Zhivago of EFNet for all his help!!! 
;; zhivago@iglou.com

 (unless (boundp 'priviledged-list) 
   (setq priviledged-list 
     '("*!tetron@*.aics.net" "*!tetron@mir.inazuma.dyn.ml.org")))
 (unless (boundp 'user-list) 
   (setq user-list 
     '("*!tetron@*.aics.net" "*!tetron@mir.inazuma.dyn.ml.org")))
 (unless (boundp 'handler-stack) 
   (setq handler-stack '(check-ping check-eval-cmd check-quit)))
 (unless (boundp 'ai-stack) (setq ai-stack nil))
 (unless (boundp 'hash-list) (setq hash-list nil))
 ;; (unless (boundp 'lambda-source-lists) (setq lambda-source-lists nil))
 (unless (boundp 'load-hooks) (setq load-hooks nil))
 (unless (boundp 'save-hooks) (setq save-hooks nil))

(load "common.cl")

(defun fuzzy-word-match (src trgt &optional (errs 1))
  (let ((n 0) (errc 0))
    (when (<= (length src) 3) (setq errs 0))
    (loop while (and (<= errc errs) (< n (length src)) (< n (length trgt))) 
	do (unless (char-equal (char src n) (char trgt n))
	     (incf errc))
	   (incf n))
    (if (and (<= errc errs) (= n (length src)) (= n (length trgt))) t nil)))

;; this takes two lists of strings and does a fuzzy match
;; using special syntax
(defun fuzzy-phrase-match (src trgt)
  (let ((n 0))
    (loop while (and (< n (length src))
		     (if (consp (nth n src)) 
			 (progn 
			   (dolist (foo (nth n src))
			     (when (fuzzy-word-match foo 
						     (nth n trgt)) 
			       (return t))))
		       (fuzzy-word-match (nth n src) (nth n trgt))))
	do (incf n))
    (= n (length src))))

;; searches y for incidence of x, where x is a fuzzy form
(defun fuzzy-search (x y)
  (let ((n 0))
    (loop while (<= n (- (length y) (length x))) do
	  (when (fuzzy-phrase-match x (subseq y n (+ n (length x))))
	    (return-from fuzzy-search n))
	  (incf n)))
  nil)

;; another spiffy recursive function
;; could also be implemented with string-split and string-join, hmmm...
(defun prepend-to-each-line (bit-to-be-added thestring)
  (unless (string= thestring "")
    (setq thestring (concatenate 'string bit-to-be-added thestring))
    (let ((n 0))
      (loop while (and (< n (- (length thestring) 1))
		       (char/= (char thestring n) #\Newline)) do 
	    (incf n))
      (incf n)
      (setq thestring (concatenate 'string (subseq thestring 0 n) 
				   (prepend-to-each-line bit-to-be-added 
							 (subseq thestring n))))))
  thestring)

(defun setnick (nick stream)
  (format stream "NICK ~A~%" nick)
  (finish-output stream))

(defun setuser (username hostname servername realname stream)
  (format stream "USER ~A ~A ~A :~A~%" 
	  username hostname servername realname) 
  (finish-output stream))

(defun snarf-opening-crap (stream)
  (loop until (string= (second (string-split (read-line stream))) "376")))

(defun join (channel stream)
  (format stream "JOIN ~A~%" channel)
  (finish-output stream))

(defun part (channel stream)
  (format stream "PART ~A~%" channel)
  (finish-output stream))

(defun sayto (channel message stream)
  (if (string/= message "")
      (prog1
	  (format stream "PRIVMSG ~A :~A~%" channel message)
	(finish-output stream)))
  nil)

(defun quit-irc (quitmessage stream)
  (format stream "QUIT :~A~%" quitmessage)
  (finish-output stream))
;;	(close stream))

(defun extract-msg (message)
  (setq message (string-split message))
  (when (string= (subseq (fourth message) 0 1) ":")
    (setf (fourth message) (subseq (fourth message) 1)))
  (nthcdr 3 message))

(defun extract-sender-nick (message)
  (subseq message 1 (position #\! message)))

(defun extract-reciver-nick (message)
  (third (string-split message)))

(defun talkchannel (message)
  (if (char= (char (extract-reciver-nick message) 0) #\#) 
      (extract-reciver-nick message) 
    (extract-sender-nick message)))

(defun privmsgp (message)
  (if (string-equal (second (string-split message)) "PRIVMSG") t nil))

(defun is-registered-user (name)
  (when (pathname-match-p name "*!tetron@*.aics.net")
    (return-from is-registered-user t))
  (dolist (usr user-list) 
    (when (pathname-match-p name usr)
      (return-from is-registered-user t)))
  nil)

(defun is-priviledged-user (name)
  (when (pathname-match-p name "*!tetron@*.aics.net")
    (return-from is-priviledged-user t))
  (dolist (usr priviledged-list) 
    (when (pathname-match-p name usr)
      (return-from is-priviledged-user t)))
  nil)

(defun check-quit (message stream)
  (when (and (is-priviledged-user 
	      (subseq (first (string-split message)) 1)) 
	     (string-equal (fourth (string-split message)) ":QUIT"))
    (quit-irc "Master says go bye bye" stream))) 

(defun check-ping (message stream)
  (when (string-equal (first (string-split message)) "PING")
    (format stream "PONG ~A~%" 
	    (second (string-split message)))
    (finish-output stream)))

(defun check-source-request (message stream)
  (when (and  (privmsgp message)
	      (string-equal (extract-reciver-nick message) "LispBot")
	      (search '("send" "source") (extract-msg message) 
		      :test 'string-equal))
    (let ( (somefile (open "lispbot.lsp")) )
      (loop while 
	    (sayto (extract-sender-nick 
		    (first (string-split message))) 
		   (read-line somefile nil nil) stream)
	  do (sleep 1)))))

(defun properp (x name)
  (when (or (is-priviledged-user name) (not (listp x))) (return-from properp t))
  (dolist (n '(ed open break quit eval defun lambda delete-file directory chdir setf
	       funcall apply priviledged-list user-list))
    (when (eql (first x) n)
      (return-from properp nil)))
  (dolist (n x)
      (unless (properp n name)
	(return-from properp nil)))
  t)

(defun check-eval-cmd (message stream)
  (when (and (is-registered-user 
	      (subseq (first (string-split message)) 1))
	     (string-equal (first (extract-msg message)) "eval"))
    (unless (ignore-errors
	     (let* ( (stm (make-string-output-stream)) 
		    (*standard-output* stm) )
	       (format stm "~%==> ~A" 
		       (write-to-string 		       
			(eval
			 (let ((evalstr (read-from-string 
					 (subseq message 
						 (+ 5 (search 
						       ":eval" message 
						       :test 
						       'string-equal))))))
			   (if (properp evalstr	(subseq (first (string-split message)) 1))
			       evalstr '(error))))))
	       (write-line (prepend-to-each-line 
			    (format nil "PRIVMSG ~A :" (talkchannel message))
			    (get-output-stream-string stm)) stream)
	       (finish-output stream))
	     t)
      (sayto (talkchannel message) "Bad form!" stream))))

(defun check-join-cmd (msg stream)
  (when (and (is-priviledged-user 
	      (subseq (first (string-split msg)) 1)) 
	     (string-equal (fourth (string-split msg)) ":join"))
    (join (second (extract-msg msg)) stream)))

(defun check-part-cmd (msg stream)
  (when (and (is-priviledged-user 
	      (subseq (first (string-split msg)) 1)) 
	     (string-equal (fourth (string-split msg)) ":part"))
    (part (second (extract-msg msg)) stream)))

(defun dumb-init () (setq handler-stack nil)
       (setq user-list nil)
       (setq handler-stack '(check-ping check-eval-cmd check-quit check-join-cmd check-part-cmd))
       ;;	(push 'check-source-request handler-stack)
       (push "*!tetron@*.aics.net" user-list)
       (push "*!~brian@bizo.biz.usyd.edu.AU" user-list)
       (push "*!orange@*.dialup.alliance.net" user-list)
       (push "*!setzer@*.direct.ca" user-list))

(defun load-state (&optional (initfile "statefile"))
  (let* ( (foofile (open initfile)) 
	 (someline nil) )
    (unless foofile (return-from load-state nil))
    (loop while (setq someline (read foofile nil)) do
	  (when (eq (first someline) 'user-list)
	    (pop someline) 
	    (setq user-list someline))
	  (dolist (bar load-hooks)
	    (funcall bar someline)))
    ;;			(when (eq (first someline) 'comp-hash)
    ;;				(pop someline) 
    ;;				(unless (boundp (first someline))
    ;;					(set (first someline) (make-hash-table :test #'equal))
    ;;					(push (first someline) hash-list))
    ;;		(setf (gethash (second someline) (eval (first someline))) (third someline)))
    (close foofile)
    t))

(defun save-state (&optional (initfile "statefile")) 
  (let ( (foofile (open initfile :direction ':output :if-exists ':overwrite)) )
    (unless foofile (return-from save-state nil))
    (push 'user-list user-list)
    (print user-list foofile)
    (pop user-list)
    ;;		(dolist (n lambda-source-lists)
    ;;			(push "lambda-func" n)
    ;;			(print n foofile)
    ;;			(pop n))
    (dolist (foo load-hooks)
      (funcall foo foofile))
    ;;		(dolist (foo hash-list)
    ;;			(maphash #'(lambda (n v)
    ;;				(format foofile "~%(\"comp-hash\" ~A \"~A\" \"~A\")" 
    ;;					(symbol-name foo) n v)) 
    ;;				(eval foo)))
    (write-line "" foofile)
    (close foofile)
    t))

;;(defun add-func (func)
;;	(unless (consp func)
;;		(write-line "Bad Form! (not a list)")
;;		(return-from add-func))
;;	(unless (eq (first func) 'lambda) (push 'lambda func))
;;	(unless (ignore-errors
;;		(push (eval func) handler-stack)
;;		(push func lambda-source-lists)
;;		t)
;;		(write-line "Bad form! (didn't eval right)") 
;;		nil))

(defun bot (&key (server-address "irc.cs.rpi.edu") 
		 (server-port 6667) (channel "#lisp") (nick "LispBot"))
  (let* ( (stream 
	   (ipc:open-network-stream :host server-address :port server-port)
	   ;;(system:make-fd-stream 
	   ;;	(connect-to-inet-socket server-address server-port)
	   ;;	:input t 
	   ;;	:output t
	   ;;	:element-type 'character
	   ;;	:auto-close t)
	   ) 
	 (somestr nil) )
    (if (open "statefile" :direction ':probe) 
	(load-state "statefile") (dumb-init))

    ;;		(load "botfunc.lsp")
    ;;		(setup-bot-func)
    
    (sleep 1)
    (setnick nick stream)
    (setuser "lispbot" "somewhere" 
	     "some-server" "The Lisp Bot" stream)
    (snarf-opening-crap stream)
    (join channel stream)
    (sayto channel "Hi everybody, I'm the LispBot!" stream)
    (loop while (setq somestr (read-line stream nil nil)) do 
	  ;;	  (setq somestr (subseq somestr 0 (- (length somestr) 1)))
	  (unless (string-equal (subseq somestr 0 4) "PING") 
	    (format t "~a~%" somestr))
	  (dolist (func-symbol handler-stack) 
	    (unless (ignore-errors
		     (funcall func-symbol somestr stream)
		     t)
	      (format t "Error executing ~a~%" func-symbol)))
	  (when (privmsgp somestr)
	    (let* ( (stm (make-string-output-stream)) 
		   (*standard-output* stm) 
		   (foo nil) )
	      (dolist (func-symbol ai-stack)
		(unless (ignore-errors
		       (setq foo
			 (funcall func-symbol 
				  (make-msg-info 
				   :sender (extract-sender-nick somestr)
				   :reciver (extract-reciver-nick somestr)
				   :message (extract-msg somestr))))
		       t)
		  (format t "Internal parsing error.  Lispbot on crack!~%"))
		
		(if foo (dolist (bar foo)
			  (write-line (prepend-to-each-line 
				       (format nil "PRIVMSG ~A :" bar) 
				       (get-output-stream-string stm)) 
				      stream))
		  (write-line (prepend-to-each-line 
			       (format nil "PRIVMSG ~A :" (talkchannel somestr)) 
			       (get-output-stream-string *standard-output*)) 
			      stream))
		(finish-output stream)))))
    (close stream)))