;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               loader.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    Loader for the CLAAR.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2009-07-09 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    GPL
;;;;
;;;;    Copyright Pascal J. Bourguignon 2009 - 2009
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU General Public License
;;;;    as published by the Free Software Foundation; either version
;;;;    2 of the License, or (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be
;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;;    PURPOSE.  See the GNU General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************

(in-package "COM.INFORMATIMAGO.COMMON-LISP.HTML")
(load #P"PACKAGES:COM;INFORMATIMAGO;COMMON-LISP;HTML401.LISP")
(generate)


(in-package "COMMON-LISP-USER")

;; (asdf-install:install :lisppaste)
;; (asdf:oos 'asdf:load-op :lisppaste)

(asdf:oos 'asdf:load-op :cl-irc)
(asdf:oos 'asdf:load-op :bordeaux-threads)
(asdf:oos 'asdf:load-op :hunchentoot)

(load "packages")
(load "web")


(claar-web:start-claar-server)

(in-package "CLAAR")

(shadow 'quit)
(use-package "COM.INFORMATIMAGO.PJB")
(use-package "COM.INFORMATIMAGO.COMMON-LISP.INTERACTIVE")



(defparameter *server*  "irc.freenode.org")
#-claar-test(defparameter *channel* "#lisp")
#-claar-test(defparameter *my-nick* "claar")
#+claar-test(defparameter *channel* "#test")
#+claar-test(defparameter *my-nick* "claar-test")


(defparameter *connection* (connect :nickname *my-nick*
                                    :server *server*))

(defvar *running* t)

(defun restart-message-loop ()
  (let* ((name "irc message loop")
         (old-thread (find name (all-threads)
                           :key (function thread-name)
                           :test (function equal))))
    (when old-thread
      (destroy-thread old-thread))
    (make-thread (lambda ()
                     (loop
                        :while *running*
                        :do (read-message-loop *connection*)))
                 :name name)))



(restart-message-loop)

(sleep 10)
(join *connection* *channel*)
(sleep 10)

(privmsg *connection* *channel* "Hello")


;; (defmacro with-say (send-function &body body)
;;   `(flet ((say (ctrl &rest args)
;;             (funcall ,send-function (format nil "~?" ctrl args))))
;;      ,@body))

(defun give-help (send-response)
  (funcall send-response "draw <s-expr> -> draw the <s-expr>"))


(defun give-bots (send-response)
  (funcall send-response "claar is a bot.  For more info: /msg claar help"))


(defun give-drawing (send-response owner arguments)
  (let ((index
         (handler-case
             (claar-web:db-insert-drawing
              owner
              (to-string (draw-list (let ((*read-eval* nil))
                                     (read-from-string arguments))
                                   :title arguments)))
           (error (err)
             (funcall send-response
                      (remove #\newline
                              (format nil "Could not draw that sexp for ~A" err)))
             (return-from give-drawing)))))
    (funcall send-response
             (format nil "~A~:[/~;~]~A" claar-web:*home-uri*
                     (char= (aref claar-web:*home-uri*
                                  (1- (length claar-web:*home-uri*)))
                            #\/) index))))


(let ((out *standard-output*))
  (defun process-command (received-time source target command send-response)
    (let ((*standard-output* out)
          (*trace-output* *standard-output*))
      (show received-time source target command send-response))
    (let* ((space (position #\space command))
           (verb  (string-upcase
                   (string-trim " " (if space
                                      (subseq command 0 space)
                                      command))))
           (args  (if space
                    (string-trim " " (subseq command space))
                    "")))
      (scase verb
        (("HELP")                      (give-help    send-response))
        (("BOTS")                      (give-bots    send-response))
        (("DRAW")                      (give-drawing send-response source args))
        (otherwise (funcall send-response "What?"))))))


(defun extract-bot-command (line)
  (let ((question (position #\? line))
        (sentence (print (mapcar (function string-upcase)
                           (split-sequence
                            #\space (substitute-if-not #\space (function alphanumericp) line)
                            :REMOVE-EMPTY-SUBSEQS t)))))
    (flet ((contains-some-words (words sentence)
             (intersection words sentence :test (function string=))))
      (when (and question
                 (or (and (contains-some-words '("WHAT" "WHO" "THERE")  sentence)
                          (contains-some-words '("IS" "ARE")            sentence)
                          (contains-some-words '("BOT" "BOTS")          sentence))
                 (member sentence '(("BOT") ("BOTS")) :test (function equal))))
        "bots"))))


(defun process-privmsg (message)
  (with-slots (source user host command arguments trailing-argument
                      connection received-time raw-message-string) message
    (when (string= command "PRIVMSG")
      (destructuring-bind (target &rest others) arguments
        (when (and (null others)
                   (or (string= target *my-nick*)
                       (string= target *channel*)))
          (let ((command
                 (if (string= target *channel*)
                   (let ((dot (position #\: trailing-argument)))
                     (if dot
                       (when (string= (string-trim " " (subseq trailing-argument 0 dot))
                                      *my-nick*)
                         (subseq trailing-argument (1+ dot)))
                       (extract-bot-command trailing-argument)))
                   trailing-argument))
                (send-response (if (string= target *channel*)
                                 (lambda (response)
                                     (privmsg connection *channel* response))
                                 (lambda (response)
                                     (privmsg connection source response)))))
            (when command
              (process-command
               received-time source target
               (string-trim " " command)
               send-response))))))))

(progn
  (remove-hooks *connection* 'irc-privmsg-message)
  (add-hook     *connection* 'irc-privmsg-message (quote process-privmsg)))



;; (defun my-hook (message)
;;      <do-something>)
;;
;; (add-hook connection 'irc-join-message #'my-hook)

;; and it will be run next time the library receives an
;; irc-join-message.  For a full list of messages you can hook into,
;; look at event.lisp.

;; Your connection object will get updated by the library with regards
;; to users joining/parting channels, you joining/parting channels,
;; etc.  Look at protocol.lisp's connection object for slots and
;; methods.

(print '(restart-message-loop))
(print '(in-package "CLAAR"))
ViewGit