diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2003 Andrew J. Bromage +Portions Copyright (c) 2003 Shae Erisson, Sven M. Hallberg, Taylor Campbell +Portions Copyright (c) 2003-2006 Members of the AUTHORS file + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject +to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY +KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE +WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMainWithHooks defaultUserHooks diff --git a/lambdabot-novelty-plugins.cabal b/lambdabot-novelty-plugins.cabal new file mode 100644 --- /dev/null +++ b/lambdabot-novelty-plugins.cabal @@ -0,0 +1,70 @@ +name: lambdabot-novelty-plugins +version: 5.0 + +license: GPL +license-file: LICENSE + +author: Don Stewart +maintainer: James Cook + +category: Development, Web +synopsis: Novelty plugins for Lambdabot +description: Lambdabot is an IRC bot written over several years by + those on the #haskell IRC channel. + . + Provided plugins: + . + [bf] Run Brainf*ck code. + [dice] Roll some dice. + [elite] zPEak Gib8erI$|-|. + [filter] More gibberish. + [numberwang] Sorry, that's not Numberwang. + [quote] Parrot profound wisdom. + [slap] Delegate punishment. + [unlambda] Run Unlambda code. + [vixen] Let's chat, honey. + +homepage: http://haskell.org/haskellwiki/Lambdabot + +build-type: Simple +cabal-version: >= 1.8 +tested-with: GHC == 7.6.3, GHC == 7.8.3 + +source-repository head + type: git + location: https://github.com/lambdabot/lambdabot.git + +library + hs-source-dirs: src + ghc-options: -Wall + -funbox-strict-fields + + exposed-modules: Lambdabot.Plugin.Novelty + other-modules: Lambdabot.Config.Novelty + Lambdabot.Plugin.Novelty.BF + Lambdabot.Plugin.Novelty.Dice + Lambdabot.Plugin.Novelty.Elite + Lambdabot.Plugin.Novelty.Filter + Lambdabot.Plugin.Novelty.Numberwang + Lambdabot.Plugin.Novelty.Quote + Lambdabot.Plugin.Novelty.Slap + Lambdabot.Plugin.Novelty.Unlambda + Lambdabot.Plugin.Novelty.Vixen + + other-modules: Lambdabot.Util.Process + + build-depends: base >= 4.4 && < 5, + binary >= 0.5, + bytestring >= 0.9, + containers >= 0.4, + dice >= 0.1, + directory >= 1.1, + lambdabot-core >= 5 && < 5.1, + misfortune >= 0.1, + process >= 1.1, + random-fu >= 0.2, + regex-tdfa >= 1.1, + + -- runtime dependencies + brainfuck == 0.1, + unlambda >= 0.1 diff --git a/src/Lambdabot/Config/Novelty.hs b/src/Lambdabot/Config/Novelty.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Config/Novelty.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} +module Lambdabot.Config.Novelty + ( bfBinary + , unlambdaBinary + ) where + +import Lambdabot.Config + +config "bfBinary" [t| String |] [| "bf" |] +config "unlambdaBinary" [t| String |] [| "unlambda" |] diff --git a/src/Lambdabot/Plugin/Novelty.hs b/src/Lambdabot/Plugin/Novelty.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Novelty.hs @@ -0,0 +1,29 @@ +module Lambdabot.Plugin.Novelty + ( bfPlugin + , dicePlugin + , elitePlugin + , filterPlugin + , numberwangPlugin + , quotePlugin + , slapPlugin + , unlambdaPlugin + , vixenPlugin + + , noveltyPlugins + + , module Lambdabot.Config.Novelty + ) where + +import Lambdabot.Config.Novelty +import Lambdabot.Plugin.Novelty.BF +import Lambdabot.Plugin.Novelty.Dice +import Lambdabot.Plugin.Novelty.Elite +import Lambdabot.Plugin.Novelty.Filter +import Lambdabot.Plugin.Novelty.Numberwang +import Lambdabot.Plugin.Novelty.Quote +import Lambdabot.Plugin.Novelty.Slap +import Lambdabot.Plugin.Novelty.Unlambda +import Lambdabot.Plugin.Novelty.Vixen + +noveltyPlugins :: [String] +noveltyPlugins = ["bf", "dice", "elite", "filter", "numberwang", "quote", "slap", "unlambda", "vixen"] diff --git a/src/Lambdabot/Plugin/Novelty/BF.hs b/src/Lambdabot/Plugin/Novelty/BF.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Novelty/BF.hs @@ -0,0 +1,39 @@ +-- Copyright (c) 2006 Jason Dagit - http://www.codersbase.com/ +-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) + +-- | A plugin for the Haskell interpreter for the brainf*ck language +-- http://www.muppetlabs.com/~breadbox/bf/ +module Lambdabot.Plugin.Novelty.BF (bfPlugin) where + +import Lambdabot.Config.Novelty +import Lambdabot.Plugin +import Lambdabot.Util.Process + +import Data.Char +import Text.Regex.TDFA + +bfPlugin :: Module () +bfPlugin = newModule + { moduleCmds = return + [ (command "bf") + { help = say "bf . Evaluate a brainf*ck expression" + , process = \msg -> do + bf <- getConfig bfBinary + ios80 (run bf msg scrub) + } + ] + } + +-- Clean up output +scrub :: String -> String +scrub = unlines . take 6 . map (' ':) . filter (not.null) . map cleanit . lines + +cleanit :: String -> String +cleanit s | s =~ terminated = "Terminated\n" + | otherwise = filter printable s + where terminated = "waitForProc" + -- the printable ascii chars are in the range [32 .. 126] + -- according to wikipedia: + -- http://en.wikipedia.org/wiki/ASCII#ASCII_printable_characters + printable x = 31 < ord x && ord x < 127 + diff --git a/src/Lambdabot/Plugin/Novelty/Dice.hs b/src/Lambdabot/Plugin/Novelty/Dice.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Novelty/Dice.hs @@ -0,0 +1,39 @@ +-- | This module is for throwing dice for e.g. RPGs. (\@dice 3d6+2) + +-- Original version copyright Einar Karttunen 2005-04-06. +-- Massive rewrite circa 2008-10-20 copyright James Cook +module Lambdabot.Plugin.Novelty.Dice (dicePlugin) where + +import Lambdabot.Plugin +import Lambdabot.Util + +import Data.List +import Data.Random.Dice (rollEm) + +type Dice = ModuleT () LB + +dicePlugin :: Module () +dicePlugin = newModule + { moduleCmds = return + [ (command "dice") + { aliases = ["roll"] + , help = say "@dice . Throw random dice. is of the form 3d6+2." + , process = doDice True + } + ] + , contextual = doDice False + } + +doDice :: Bool -> String -> Cmd Dice () +doDice printErrs text = do + user <- showNick =<< getSender + result <- io (rollEm text) + case result of + Left err -> if printErrs + then say (trimError err) + else return () + Right str -> + say (limitStr 75 (user ++ ": " ++ str)) + + where + trimError = concat . intersperse ": " . tail . lines . show diff --git a/src/Lambdabot/Plugin/Novelty/Elite.hs b/src/Lambdabot/Plugin/Novelty/Elite.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Novelty/Elite.hs @@ -0,0 +1,93 @@ +-- (c) Josef Svenningsson, 2005 +-- Licence: No licence, public domain + +-- Inspired by the following page: +-- http://www.microsoft.com/athome/security/children/kidtalk.mspx +module Lambdabot.Plugin.Novelty.Elite (elitePlugin) where + +import Lambdabot.Plugin +import Lambdabot.Util + +import Control.Arrow +import Control.Monad +import Data.Char +import Data.Maybe +import Text.Regex.TDFA + +elitePlugin :: Module () +elitePlugin = newModule + { moduleCmds = return + [ (command "elite") + { aliases = ["leet", "l33t", "1337"] + , help = say "elite . Translate English to elitespeak" + , process = \args -> case words args of + [] -> say "Say again?" + wds -> do let instr = map toLower (unwords wds) + say =<< io (translateLine instr) + + } + ] + } + +translateLine :: String -> IO String +translateLine = fmap (dropWhile isSpace) . translate . (' ':) +-- extra space allows whole-word patterns to match at start + +translate :: String -> IO String +translate [] = return [] +translate str = do + let alts = [ (subst match',rest) + | (re, subst) <- ruleList + , mr <- maybeToList (matchM re str) + , null (mrBefore mr) + , let match' = mrMatch mr + rest = mrAfter mr + ] + (subst,rest) <- random alts + liftM (subst ++) (translate rest) + +ruleList :: [(Regex, String -> String)] +ruleList = map (first makeRegex) + [ (".", id ) + , (".", map toUpper ) + , ("a", const "4" ) + , ("b", const "8" ) + , (" be ", const " b " ) + , ("c", const "(" ) + , ("ck", const "xx" ) + , ("cks ", const "x " ) + , ("cks ", const "x0rs " ) + , ("cks ", const "x0rz " ) + , (" cool ",const " kewl ") + , ("e", const "3" ) + , ("elite", const "1337" ) + , ("elite", const "leet" ) + , ("f", const "ph" ) + , (" for ", const " 4 " ) + , ("g", const "9" ) + , ("h", const "|-|" ) + , ("k", const "x" ) + , ("l", const "|" ) + , ("l", const "1" ) + , ("m", const "/\\/\\") + , ("o", const "0" ) + , ("ph", const "f" ) + , ("s", const "z" ) + , ("s", const "$" ) + , ("s", const "5" ) + , ("s ", const "z0rz " ) + , ("t", const "7" ) + , ("t", const "+" ) + , (" the ", const " teh " ) + , (" to ", const " 2 " ) + , (" to ", const " too " ) + , (" to ", const " tu " ) + , (" too ", const " to " ) + , ("v", const "\\/" ) + , ("w", const "\\/\\/") + , (" you ", const " u " ) + , (" you ", const " yu " ) + , (" you ", const " joo " ) + , ("z", const "s" ) + ] + diff --git a/src/Lambdabot/Plugin/Novelty/Filter.hs b/src/Lambdabot/Plugin/Novelty/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Novelty/Filter.hs @@ -0,0 +1,69 @@ +-- | GNU Talk Filters +-- needs: http://www.hyperrealm.com/main.php?s=talkfilters +-- Edward Kmett 2006 + +module Lambdabot.Plugin.Novelty.Filter (filterPlugin) where + +import Lambdabot.Plugin +import Lambdabot.Util + +import Control.Applicative +import Data.Maybe +import System.Directory (findExecutable) +import System.Process + +-- State consists of a map from filter name to executable path + +filterPlugin :: Module [(String, FilePath, String)] +filterPlugin = newModule + { moduleDefState = catMaybes <$> sequence + [ do + mbPath <- io (findExecutable name) + return $! do + path <- mbPath + Just (name, path, descr) + | (name, descr) <- filters + ] + + , moduleCmds = do + activeFilters <- readMS + return + [ (command name) + { help = say descr + , process = \s -> do + case words s of + [] -> say ("usage: " ++ name ++ " ") + t -> ios80 (runFilter path (unwords t)) + } + | (name, path, descr) <- activeFilters + ] + } + +filters :: [(String, String)] +filters = + [ ("austro", "austro . Talk like Ahhhnold") + , ("b1ff", "b1ff . B1ff of usenet yore") + , ("brooklyn", "brooklyn . Yo") + , ("chef", "chef . Bork bork bork") + , ("cockney", "cockney . Londoner accent") + , ("drawl", "drawl . Southern drawl") + , ("dubya", "dubya . Presidential filter") + , ("fudd", "fudd . Fudd, Elmer") + , ("funetak", "funetak . Southern drawl") + , ("jethro", "jethro . Now listen to a story 'bout a man named Jed...") + , ("jive", "jive . Slap ma fro") + , ("kraut", "kraut . German accent") + , ("pansy", "pansy . Effeminate male") + , ("pirate", "pirate . Talk like a pirate") + , ("postmodern", "postmodern . Feminazi") + , ("redneck", "redneck . Deep south") + , ("valspeak", "valley . Like, ya know?") + , ("warez", "warez . H4x0r") + ] + +runFilter :: String -> String -> IO String +runFilter f s = do + out <- readProcess f [] s + return $ result out + where result [] = "Couldn't run the filter." + result xs = unlines . filter (not . all (==' ')) . lines $ xs diff --git a/src/Lambdabot/Plugin/Novelty/Numberwang.hs b/src/Lambdabot/Plugin/Novelty/Numberwang.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Novelty/Numberwang.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE TypeFamilies #-} + +module Lambdabot.Plugin.Novelty.Numberwang (numberwangPlugin) where + +import Control.Applicative +import Control.Monad +import Data.Random +import Data.Random.Distribution.Poisson +import Lambdabot.Plugin +import Numeric + + +data NumberwangState = State + { nextCmd :: !Int -- number of invocations of @numberwang before the next numberwang + , nextCon :: !Int -- number of contextual occurrences of numbers before next numberwang + } + +cmdDist :: RVar Int +cmdDist = poisson (3.5 :: Double) + +conDist :: RVar Int +conDist = poisson (32 :: Double) + +numberwangPlugin :: Module NumberwangState +numberwangPlugin = newModule + { moduleDefState = sample (State <$> cmdDist <*> conDist) + , moduleCmds = return + [ (command "numberwang") + { help = say "@numberwang : Determines if it is Numberwang." + , process = doNumberwang True . length . words + } + ] + , contextual = doNumberwang False . length . (numbers :: String -> [Double]) + } + +numbers :: RealFrac t => String -> [t] +numbers [] = [] +numbers cs = case readFloat cs of + (n, rest):_ -> n : numbers rest + _ -> numbers (tail cs) + +doNumberwang :: (Num a, Ord a, MonadLBState m, LBState m ~ NumberwangState) => + Bool -> a -> Cmd m () +doNumberwang cmd n + | n <= 0 = when cmd $ say "What number?" + | otherwise = do + isNumberwang <- checkNumberwang cmd 1 + if isNumberwang + then say "That's Numberwang!" + else when cmd $ say "Sorry, that's not Numberwang." + +withState :: (MonadLBState m, LBState m ~ NumberwangState) => + Bool -> (Int -> (Int -> m ()) -> RVar Int -> m a) -> m a +withState True f = withMS $ \st setST -> + f (nextCmd st) (\n -> setST st {nextCmd = n}) cmdDist +withState False f = withMS $ \st setST -> + f (nextCon st) (\n -> setST st {nextCon = n}) conDist + +checkNumberwang :: (MonadLBState m, LBState m ~ NumberwangState) => + Bool -> Int -> m Bool +checkNumberwang cmd l = withState cmd $ \ n setN nDist -> do + if n <= l + then do + setN =<< lb (sample nDist) + return True + else do + setN (n - l) + return False diff --git a/src/Lambdabot/Plugin/Novelty/Quote.hs b/src/Lambdabot/Plugin/Novelty/Quote.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Novelty/Quote.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleContexts #-} +-- | Support for quotes +module Lambdabot.Plugin.Novelty.Quote (quotePlugin) where + +import Lambdabot.Plugin +import Lambdabot.Util + +import qualified Data.ByteString.Char8 as P +import Data.Char +import Data.Fortune +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Text.Regex.TDFA + +type Key = P.ByteString +type Quotes = M.Map Key [P.ByteString] +type Quote = ModuleT Quotes LB + +quotePlugin :: Module (M.Map P.ByteString [P.ByteString]) +quotePlugin = newModule + { moduleSerialize = Just mapListPackedSerial + , moduleDefState = return M.empty + , moduleInit = modifyMS (M.filter (not . null)) + + , moduleCmds = return + [ (command "quote") + { help = say "quote : Quote or a random person if no nick is given" + , process = runQuote . strip isSpace + } + , (command "remember") + { help = say "remember : Remember that said ." + , process = runRemember . strip isSpace + } + , (command "forget") + { help = say "forget nick quote. Delete a quote" + , process = runForget . strip isSpace + } + , (command "ghc") + { help = say "ghc. Choice quotes from GHC." + , process = const (fortune ["ghc"]) + } + , (command "fortune") + { help = say "fortune. Provide a random fortune" + , process = const (fortune []) + } + , (command "yow") + { help = say "yow. The zippy man." + , process = const (fortune ["zippy"]) + } + , (command "arr") + { help = say "arr. Talk to a pirate" + , process = const (fortune ["arr"]) + } + , (command "yarr") + { help = say "yarr. Talk to a scurvy pirate" + , process = const (fortune ["arr", "yarr"]) + } + , (command "keal") + { help = say "keal. Talk like Keal" + , process = const (fortune ["keal"]) + } + , (command "b52s") + { help = say "b52s. Anyone noticed the b52s sound a lot like zippy?" + , process = const (fortune ["b52s"]) + } + , (command "pinky") + { help = say "pinky. Pinky and the Brain" + , process = \s -> fortune $ if "pondering" `isInfixOf` s + then ["pinky-pondering"] + else ["pinky-pondering", "pinky"] + } + , (command "brain") + { help = say "brain. Pinky and the Brain" + , process = const (fortune ["brain"]) + } + , (command "palomer") + { help = say "palomer. Sound a bit like palomer on a good day." + , process = const (fortune ["palomer"]) + } + , (command "girl19") + { help = say "girl19 wonders what \"discriminating hackers\" are." + , process = const (fortune ["girl19"]) + } + , (command "v") + { aliases = ["yhjulwwiefzojcbxybbruweejw"] + , help = getCmdName >>= \v -> case v of + "v" -> say "let v = show v in v" + _ -> say "V RETURNS!" + , process = const (fortune ["notoriousV"]) + } + , (command "protontorpedo") + { help = say "protontorpedo is silly" + , process = const (fortune ["protontorpedo"]) + } + , (command "nixon") + { help = say "Richard Nixon's finest." + , process = const (fortune ["nixon"]) + } + , (command "farber") + { help = say "Farberisms in the style of David Farber." + , process = const (fortune ["farber"]) + } + ] + } + +fortune :: [FilePath] -> Cmd Quote () +fortune xs = io (resolveFortuneFiles All xs >>= randomFortune) >>= say + +------------------------------------------------------------------------ + +-- the @remember command stores away a quotation by a user, for future +-- use by @quote + +-- error handling! +runRemember :: String -> Cmd Quote () +runRemember str + | null rest = say "Incorrect arguments to quote" + | otherwise = do + withMS $ \fm writer -> do + let ss = fromMaybe [] (M.lookup (P.pack nm) fm) + fm' = M.insert (P.pack nm) (P.pack q : ss) fm + writer fm' + say =<< randomSuccessMsg + where + (nm,rest) = break isSpace str + q = drop 1 rest + +-- @forget, to remove a quote +runForget :: String -> Cmd Quote () +runForget str + | null rest = say "Incorrect arguments to quote" + | otherwise = do + ss <- withMS $ \fm writer -> do + let ss = fromMaybe [] (M.lookup (P.pack nm) fm) + fm' = case delete (P.pack q) ss of + [] -> M.delete (P.pack nm) fm + ss' -> M.insert (P.pack nm) ss' fm + writer fm' + return ss + say $ if P.pack q `elem` ss + then "Done." + else "No match." + where + (nm,rest) = break isSpace str + q = drop 1 rest + +-- +-- the @quote command, takes a user nm to choose a random quote from +-- +runQuote :: String -> Cmd Quote () +runQuote str = + say =<< search (P.pack nm) (P.pack pat) =<< readMS + where (nm, p) = break isSpace str + pat = drop 1 p + +search :: Key -> P.ByteString -> Quotes -> Cmd Quote String +search key pat db + | M.null db = return "No quotes yet." + + | P.null key = do + (key', qs) <- random (M.toList db) -- quote a random person + fmap (display key') (random qs) + + | P.null pat, Just qs <- mquotes = + fmap (display key) (random qs) + + | P.null pat = match' key allquotes + + | Just qs <- mquotes = match' pat (zip (repeat key) qs) + + | otherwise = do + r <- randomFailureMsg + return $ "No quotes for this person. " ++ r + + where + mquotes = M.lookup key db + allquotes = concat [ zip (repeat who) qs | (who, qs) <- M.assocs db ] + + match' p ss = do + re <- makeRegexOptsM defaultCompOpt {caseSensitive = False, newSyntax = True} + defaultExecOpt {captureGroups = False} p + + let rs = filter (match re . snd) ss + if null rs + then do r <- randomFailureMsg + return $ "No quotes match. " ++ r + else do (who, saying) <- random rs + return $ P.unpack who ++ " says: " ++ P.unpack saying + + display k msg = (if P.null k then " " else who ++ " says: ") ++ saying + where saying = P.unpack msg + who = P.unpack k diff --git a/src/Lambdabot/Plugin/Novelty/Slap.hs b/src/Lambdabot/Plugin/Novelty/Slap.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Novelty/Slap.hs @@ -0,0 +1,79 @@ +-- | Support for quotes +module Lambdabot.Plugin.Novelty.Slap (slapPlugin) where + +import Lambdabot.Plugin +import Lambdabot.Util + +type Slap = ModuleT () LB + +slapPlugin :: Module () +slapPlugin = newModule + { moduleCmds = return + [ (command "slap") + { aliases = ["smack"] + , help = say "slap . Slap someone amusingly." + , process = slap + } + ] + } + +------------------------------------------------------------------------ + +slap :: String -> Cmd Slap () +slap "me" = do + target <- showNick =<< getSender + slapRandom target +slap "yourself" = do + target <- showNick =<< getLambdabotName + slapRandom target +slap target = + slapRandom target + +slapRandom :: String -> Cmd Slap () +slapRandom tgt = say . ($ tgt) =<< random slapList + +slapList :: [String -> String] +slapList = + [(\x -> "/me slaps " ++ x) + ,(\x -> "/me smacks " ++ x ++ " about with a large trout") + ,(\x -> "/me beats up " ++ x) + ,(\x -> "/me pokes " ++ x ++ " in the eye") + ,(\x -> "why on earth would I slap " ++ x ++ "?") + ,(\x -> "*SMACK*, *SLAM*, take that " ++ x ++ "!") + ,(\_ -> "/me activates her slap-o-matic...") + ,(\x -> "/me orders her trained monkeys to punch " ++ x) + ,(\x -> "/me smashes a lamp on " ++ possesiveForm x ++ " head") + ,(\x -> "/me hits " ++ x ++ " with a hammer, so they breaks into a thousand pieces") + ,(\x -> "/me throws some pointy lambdas at " ++ x) + ,(\x -> "/me loves " ++ x ++ ", so no slapping") + ,(\x -> "/me would never hurt " ++ x ++ "!") + ,(\x -> "go slap " ++ x ++ " yourself") + ,(\_ -> "I won't; I want to go get some cookies instead.") + ,(\x -> "I'd rather not; " ++ x ++ " looks rather dangerous.") + ,(\_ -> "I don't perform such side effects on command!") + ,(\_ -> "stop telling me what to do") + ,(\x -> "/me clobbers " ++ x ++ " with an untyped language") + ,(\x -> "/me pulls " ++ x ++ " through the Evil Mangler") + ,(\x -> "/me secretly deletes " ++ possesiveForm x ++ " source code") + ,(\x -> "/me places her fist firmly on " ++ possesiveForm x ++ " jaw") + ,(\x -> "/me locks up " ++ x ++ " in a Monad") + ,(\x -> "/me submits " ++ possesiveForm x ++ " email address to a dozen spam lists") + ,(\x -> "/me moulds " ++ x ++ " into a delicous cookie, and places it in her oven") + ,(\_ -> "/me will count to five...") + ,(\x -> "/me jabs " ++ x ++ " with a C pointer") + ,(\x -> "/me is overcome by a sudden desire to hurt " ++ x) + ,(\x -> "/me karate-chops " ++ x ++ " into two equally sized halves") + ,(\x -> "Come on, let's all slap " ++ x) + ,(\x -> "/me pushes " ++ x ++ " from his chair") + ,(\x -> "/me hits " ++ x ++ " with an assortment of kitchen utensils") + ,(\x -> "/me slaps " ++ x ++ " with a slab of concrete") + ,(\x -> "/me puts on her slapping gloves, and slaps " ++ x) + ,(\x -> "/me decomposes " ++ x ++ " into several parts using the Banach-Tarski theorem and reassembles them to get two copies of " ++ x ++ "!") + ] + +-- | The possesive form of a name, "x's" +possesiveForm :: String -> String +possesiveForm [] = [] +possesiveForm x + | last x == 's' = x ++ "'" + | otherwise = x ++ "'s" diff --git a/src/Lambdabot/Plugin/Novelty/Unlambda.hs b/src/Lambdabot/Plugin/Novelty/Unlambda.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Novelty/Unlambda.hs @@ -0,0 +1,32 @@ +-- Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) +-- +-- | A plugin for the Haskell interpreter for the unlambda language +-- +-- http://www.madore.org/~david/programs/unlambda/ +module Lambdabot.Plugin.Novelty.Unlambda (unlambdaPlugin) where + +import Lambdabot.Config.Novelty +import Lambdabot.Plugin +import Lambdabot.Util.Process +import Text.Regex.TDFA + +unlambdaPlugin :: Module () +unlambdaPlugin = newModule + { moduleCmds = return + [ (command "unlambda") + { help = say "unlambda . Evaluate an unlambda expression" + , process = \msg -> do + binary <- getConfig unlambdaBinary + ios80 (run binary msg scrub) + } + ] + } + +scrub :: String -> String +scrub = unlines . take 6 . map (' ':) . lines . cleanit + +cleanit :: String -> String +cleanit s | s =~ terminated = "Terminated\n" + | otherwise = s + where terminated = "waitForProc" diff --git a/src/Lambdabot/Plugin/Novelty/Vixen.hs b/src/Lambdabot/Plugin/Novelty/Vixen.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Plugin/Novelty/Vixen.hs @@ -0,0 +1,97 @@ +-- | Talk to hot chixxors. + +-- (c) Mark Wotton +-- Serialisation (c) 2007 Don Stewart + +module Lambdabot.Plugin.Novelty.Vixen (vixenPlugin) where + +import Lambdabot.Plugin +import Lambdabot.Util + +import Control.Arrow ((***)) +import Control.Monad +import Data.Binary +import qualified Data.ByteString.Char8 as P +import System.Directory +import Text.Regex.TDFA + +vixenPlugin :: Module (Bool, String -> IO [Char]) +vixenPlugin = newModule + { moduleCmds = return + [ (command "vixen") + { help = say "vixen . Sergeant Curry's lonely hearts club" + , process = \txt -> say =<< io . ($ txt) . snd =<< readMS + } + , (command "vixen-on") + { privileged = True + , help = do + me <- showNick =<< getLambdabotName + say ("vixen-on: turn " ++ me ++ " into a chatterbot") + , process = const $ do + modifyMS $ \(_,r) -> (True, r) + say "What's this channel about?" + } + , (command "vixen-off") + { privileged = True + , help = do + me <- showNick =<< getLambdabotName + say ("vixen-off: shut " ++ me ++ "up") + , process = const $ do + modifyMS $ \(_,r) -> (False, r) + say "Bye!" + } + ] + + -- if vixen-chat is on, we can just respond to anything + , contextual = \txt -> do + (alive, k) <- readMS + if alive then io (k txt) >>= say + else return () + + , moduleDefState = return (False, const (return "")) + + -- suck in our (read only) regex state from disk + -- compile it, and stick it in the plugin state + , moduleInit = do + vixenFile <- lb (findOrCreateLBFile "vixen") + b <- io (doesFileExist vixenFile) + when b $ do + st <- io (decodeFile vixenFile) + let compiled = map (makeRegex *** id) (st :: [(String, WTree)]) + s = vixen (mkResponses compiled) + modifyMS $ \(v,_) -> (v, s) + } + +------------------------------------------------------------------------ + +vixen :: (String -> WTree) -> String -> IO String +vixen k key = P.unpack `fmap` randomW (k key) + +randomW :: WTree -> IO P.ByteString +randomW (Leaf a) = return a +randomW (Node ls) = random ls >>= randomW + +mkResponses :: RChoice -> String -> WTree +mkResponses choices them = (\((_,wtree):_) -> wtree) $ + filter (\(reg,_) -> match reg them) choices + +------------------------------------------------------------------------ +-- serialisation for the vixen state +-- +-- The tree of regexes and responses is written in binary form to +-- State/vixen, and we suck it in on module init, then lazily regexify it all + +data WTree = Leaf !P.ByteString | Node ![WTree] + deriving Show + +instance Binary WTree where + put (Leaf s) = putWord8 0 >> put s + put (Node ls) = putWord8 1 >> put ls + get = do + tag <- getWord8 + case tag of + 0 -> liftM Leaf get + 1 -> liftM Node get + _ -> error "Vixen plugin error: unknown tag" + +type RChoice = [(Regex, WTree)] -- compiled choices diff --git a/src/Lambdabot/Util/Process.hs b/src/Lambdabot/Util/Process.hs new file mode 100644 --- /dev/null +++ b/src/Lambdabot/Util/Process.hs @@ -0,0 +1,19 @@ +-- Copyright (c) 2004-6 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) + +module Lambdabot.Util.Process + ( run + ) where + +import System.Process + +run :: FilePath -> String -> (String -> String) -> IO String +run binary src scrub = do + (_,out,err) <- readProcessWithExitCode binary [] src + let o = scrub out + e = scrub err + return $ case () of {_ + | null o && null e -> "Done." + | null o -> e + | otherwise -> o + }