syncbot/syncbot.scm

#!/usr/bin/guile \
-e main -s
!#

;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org>

;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA

(use-modules (8sync)
             (8sync systems irc)
             (ice-9 format)
             (ice-9 match)
             (srfi srfi-37)
             (oop goops))

(set! *random-state* (random-state-from-platform))


(define (random-choice lst)
  (list-ref lst (random (length lst))))


(define (random-food-response)
  (random-choice
   `("Yippie! *does a dance!*"
     "oh boy! oh girl! oh arbitrary-gender-exclamation!"
     "Scrum-diddly-umptious!"
     "eeeee!"
     ":D :D :D"
     "*catches botsnack in midair*"
     "YESSSSSS *nom nom nom nom nom*"
     "thanks!"
     "*eyes treat suspiciously... then furiously devours it!*"
     "*gratefully affirms that botsnack is the most important command an irc bot can know*"
     ,(string-concatenate
       (list "Horray! A delicious "
             (random-choice
              '("pear" "banana"
                "caramel" "tapioca pudding"
                "fudge slurry"
                "banana walnut muffin"
                "iced soy vanilla mocha salted caramel latte"
                "cartoon canine snack"))
             "!")))))

(define fate-ladder
  '((-2 . "terrible")
    (-1 . "poor")
    (0 . "mediocre")
    (1 . "average")
    (2 . "fair")
    (3 . "good")
    (4 . "great")
    (5 . "superb")
    (6 . "fantastic")
    (7 . "epic")
    (8 . "legendary")))

(define (fate-ladder-value roll-number)
  (cond ((< roll-number -2)
         "it's... really not good...")
        ((> roll-number 8)
         "it's... off the charts!")
        (else
         (assoc-ref fate-ladder roll-number))))

(define fate-dice-map
  '((-1 . "[-]") (0 . "[_]") (1 . "[+]")))

(define* (roll-fate #:optional (base-roll 0))
  (let* ((rolls (map (lambda _ (- (random 3) 1)) (iota 4)))
         (dice-string (string-join
                       (map (lambda (x) (assoc-ref fate-dice-map x))
                            rolls)
                       " "))
         (score (apply + base-roll rolls)))
    (format #f "Rolling at ~a: ~a -> ~a!  (~a)"
            base-roll dice-string score
            (fate-ladder-value score))))

(define-class <syncbot> (<irc-bot>))

(define-method (handle-line (irc-bot <syncbot>) message
                            speaker channel line emote?)
  (define my-name (irc-bot-username irc-bot))
  (define (looks-like-me? str)
    (or (equal? str my-name)
        (equal? str (string-concatenate (list my-name ":")))))
  (define (reply-line line)
    (<- (actor-id irc-bot) 'send-line channel
        line))

  (let ((channel (if (looks-like-me? channel)
                     speaker
                     channel)))
    (match (string-split line #\space)
      (((? looks-like-me? _) action action-args ...)
       (match action
         ("botsnack"
          (reply-line (random-food-response)))
         ((or "hello" "hello!" "hello." "greetings" "greetings." "greetings!"
              "hei" "hei." "hei!" "hi" "hi." "hi!")
          (reply-line (format #f "Oh hi ~a!" speaker)))
         ("failboat"
          (/ 1 0))
         ("help"
          (reply-line "I can't help you... I can't even help myself!"))
         ("echo"
          (reply-line (string-join action-args " ")))
         ("roll-fate"
          (let ((base-roll
                 (match action-args
                   (((? string->number base-roll) rest ...)
                    (string->number base-roll))
                   (_ 0))))
            (reply-line (format #f "~a: ~a"
                                speaker (roll-fate base-roll)))))
         ("d6"
          (reply-line (format #f "~a: *rolls*... you get a ~a!"
                              speaker (+ (random 6) 1))))
         ("d20"
          (let ((score (+ (random 20) 1)))
            (if (eqv? score 20)
                (reply-line
                 (format #f "~a: *rolls*... you get a ~a! *critical!*"
                         speaker score))
                (reply-line
                 (format #f "~a: *rolls*... you get a ~a!"
                         speaker score)))))
         ("root"
          (match action-args
            (((or "on" "for") whom ...)
             (reply-line
              (format #f "~a ~a! :D"
                      (random-choice '("Gooooooo"
                                       "Woo woo"
                                       "Keep it up"
                                       "Yay yay"))
                      (string-join whom " "))))
            (_ (reply-line "Root for whom?"))))
         ("sympathize"
          (match action-args
            (("with" whom ...)
             (reply-line (format #f "~a ~a! :("
                                 (random-choice
                                  '("I'm so sorry"
                                    "Sorry"
                                    "I hope things get better"
                                    "Sorry, and good luck"))
                                 (string-join whom " "))))
            (_ (reply-line "Sympathize with whom?"))))
         ((or "greet" "welcome")
          (reply-line
           (format #f "~a ~a!"
                   (random-choice '("Great to see you"
                                    "Hey, welcome"
                                    "Thanks for joining us"
                                    "Good to see you"
                                    "Thanks for dropping in"
                                    "Welcome"))
                   (string-join action-args " "))))
         ("hug"
          (reply-line
           (format #f "*~a ~a ~a*"
                   my-name
                   (random-choice
                    '("gives a big bear hug to"
                      "gives a friendly hug to"
                      "glomps" "hugs" "embraces"
                      "gives a big ol fuzzy hug"
                      "gives a gentle pet on the back to"))
                   (string-join action-args " "))))
         ("sorry"
          (reply-line (random-choice
                       '("It's okay."
                         "I accept your apology."
                         "No worries."))))
         ("shut"
          (match action-args
            (("up" _ ...)
             (reply-line "No, YOU shut up!"))
            (_
             (reply-line "Shut huh???"))))
         ("give"
          (match action-args
            ((object "to" whom ...)
             (reply-line
              (format #f "*gives ~a to ~a*"
                      object (string-join whom " "))))
            (_ (reply-line "*stares*"))))
         ((or "d12" "d10" "d4")
          (reply-line
           (format #f "~a: *checks bag*... I left that one at home :("
                   speaker)))
         ("source"
          (for-each
           reply-line
           '("I'm a little irc bot for 8sync!  Patches welcome / happy hacking!"
             "My source: https://notabug.org/cwebber/syncbot"
             "8sync's source: https://notabug.org/cwebber/8sync")))
         ;; Add yours here
         (whatever
          (display whatever)(newline)
          (reply-line "*stupid puppy look*"))))
      (((or ":)" ":p" ";)" ":D" ":P" ";D" ";P") rest ...)
       ;; only wink back once every 10 times
       (if (equal? (random 10) 1)
           (reply-line (random-choice '(";)" ":)" ":D" "^_^" ":3")))))
      (_
       (cond
        (emote?
         (format #t "~a emoted ~s in channel ~a\n"
                 speaker line channel))
        (else
         (format #t "~a said ~s in channel ~a\n"
                 speaker line channel)))))))


(define (display-help scriptname)
  (format #t "Usage: ~a [OPTION] username" scriptname)
  (display "
  -h, --help                  display this text
      --server=SERVER-NAME    connect to SERVER-NAME
                                defaults to \"irc.freenode.net\"
      --channels=CHANNEL1,CHANNEL2
                              join comma-separated list of channels on connect
                                defaults to \"##botchat\"")
  (newline))


(define (parse-args scriptname args)
  (args-fold (cdr args)
             (list (option '(#\h "help") #f #f
                           (lambda _
                             (display-help scriptname)
                             (exit 0)))
                   (option '("server") #t #f
                           (lambda (opt name arg result)
                             `(#:server ,arg ,@result)))
                   (option '("channels") #t #f
                           (lambda (opt name arg result)
                             `(#:channels ,(string-split arg #\,)
                               ,@result))))
             (lambda (opt name arg result)
               (format #t "Unrecognized option `~a'\n" name)
               (exit 1))
             (lambda (option result)
               `(#:username ,option ,@result))
             '()))

(define* (run-bot #:key (username "sinkbot")
                  (server "irc.freenode.net")
                  (channels '("##botchat"))
                  (repl #f))
  (define hive (make-hive))
  (define irc-bot
    (bootstrap-actor* hive <syncbot> "irc-bot"
                      #:username username
                      #:server server
                      #:channels channels))
  ;; TODO: load REPL
  (run-hive hive '()))

(define (main args)
  (define parsed-args (parse-args "syncbot.scm" args))
  (apply (lambda* (#:key username #:allow-other-keys)
           (when (not username)
             (display "Error: username not specified!")
             (newline) (newline)
             (display-help "syncbot.scm")
             (exit 1)))
         parsed-args)
  (apply run-bot parsed-args))