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 (eightsync systems irc)
             (eightsync agenda)
             (ice-9 match)
             (srfi srfi-1))

(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* (roll-1d6)
  (let* ((numbers '(-5 -3 -1 2 4 6))
         (rolld6
          (lambda () (list-ref
                      numbers
                      (random 6)))))
    (let rolling ((rolled
                   (cons (rolld6) '())))
      (cond
       ((and (= 1 (length rolled))
             (member
              (car rolled) '(-5 6)))
        (rolling (cons (rolld6) rolled)))
       ((and (< 1 (length rolled))
             (equal? (car rolled)
                     (car (cdr rolled))))
        (rolling (cons (rolld6) rolled)))
       ((= 1 (length rolled))
        (car rolled))
       (else
        (apply + (cdr rolled)))))))


(define (handle-message socket my-name speaker
                        channel message is-action)
  (define (looks-like-me? str)
    (or (equal? str my-name)
        (equal? str (string-concatenate (list my-name ":")))))
  (let ((channel (if (looks-like-me? channel)
                     speaker
                     channel)))
    (write message)
    (match (string-split message #\space)
      (((? looks-like-me? _) action action-args ...)
       (match action
         ("botsnack"
          (irc-send-message socket channel (random-food-response)))
         ((or "hello" "hello!" "hello." "greetings" "greetings." "greetings!"
              "hei" "hei." "hei!" "hi" "hi." "hi!")
          (irc-send-formatted socket channel "Oh hi ~a!" speaker))
         ("failboat"
          (/ 1 0))
         ("help"
          (irc-send-message socket channel
                            "I can't help you... I can't even help myself!"))
         ("echo"
          (irc-send-message socket channel
                            (string-join action-args " ")))
         ("roll-fate"
          (let ((base-roll
                 (match action-args
                   (((? string->number base-roll) rest ...)
                    (string->number base-roll))
                   (_ 0))))
            (irc-send-formatted socket channel
                                "~a: ~a"
                                speaker (roll-fate base-roll))))
         ("d6"
          (irc-send-formatted socket channel
                              "~a: *rolls*... you get a ~a!"
                              speaker (+ (random 6) 1)))
         ((or "1d6" "±d6")
          (irc-send-formatted socket channel
                              "~a: *rolls*... you get a ~a!"
                              speaker (roll-1d6)))
         ("d20"
          (let ((score (+ (random 20) 1)))
            (if (eqv? score 20)
                (irc-send-formatted socket channel
                                "~a: *rolls*... you get a ~a! *critical!*"
                                speaker score)
                (irc-send-formatted socket channel
                                    "~a: *rolls*... you get a ~a!"
                                    speaker score))))
         ((or "d12" "d10" "d4")
          (irc-send-formatted socket channel
                              "~a: *checks bag*... I left that one at home :("
                              speaker))
         ;; Add yours here
         (whatever
          (display whatever)(newline)
          (irc-format socket "PRIVMSG ~a :*stupid puppy look*" channel))))
      ((":)" ...)
       ;; only wink back once every 20 times
       (if (equal? (random 20) 1)
           (irc-send-message
            socket channel
            (random-choice '(";)" ":)" ":D" "^_^" ":3")))))
      (_
       (cond
        (is-action
         (format #t "~a emoted ~s in channel ~a\n"
                 speaker message channel))
        (else
         (format #t "~a said ~s in channel ~a\n"
                 speaker message channel)))))))

(define main
  (make-irc-bot-cli (make-handle-line
                     #:handle-privmsg (wrap-apply handle-message))))