Commits

David Krentzlin committed 58848c7

finished first implementation

Comments (0)

Files changed (7)

+syntax: glob
+*.so
-;; 
-;; %%HEADER%%
-;;
 
-(use random-bsd vandusen irc)
-
-
-;;some options
 (define *autolearn* #f)
 (define *quota*     #f)
 
 
 (define (make-dictionary) (make-hash-table string-ci=?))
 (define dictionary? hash-table?)
-(define dictionary-set!   hash-table-set!)
+(define dictionary-set! hash-table-set!)
 (define (dictionary-ref dict key #!optional (default #f))
   (hash-table-ref/default dict key default))
 (define dictionary-values hash-table-values)
 (define dictionary-clear! hash-table-clear!)
 (define dictionary-size hash-table-size)
 
-
-
 (define *probabilities* (make-dictionary))
 
 
    (lambda (token successor)
      (if successor
        (if (not (token-pair-known? dict token successor))
-           (learn-token-pair! dict token successor)
+           (learn-token-pair!  dict token successor)
            (update-token-pair! dict token successor))
        (dictionary-set! dict token (make-dictionary))))
    token-list))
   (let ((dict (make-dictionary))
         (tokens (tokenize-input text)))
     (unless (null? tokens)
-      (dictionary-clear! probs)
       (learn-tokens! dict tokens)
       (update-probabilities! probs dict)
       probs)))
   (or (irregex-replace "([!.?]).*$" text 1)
       text))
 
-
 (define (quota-exceeded?)
   (and (number? *quota*)
        (> (dictionary-size *probabilities*) *quota*)))
 
 
-(define markov-clear:sre     (irregex '(: "markov" (+ space) (submatch "clear") (* any))))
-(define markov-autolearn:sre (irregex '(: "markov" (+ space) "autolearn" (+ space) (submatch (or "on" "off")) (* any))))
-(define markov-learn:sre     (irregex '(: "markov" (+ space) "learn" (+ space) (submatch (+ any)))))
 
-(define markov-quota:sre     (irregex  '(: "markov" (+ space) "quota" (+ space)  (or (submatch (or "disable" "show")) (: (submatch "set") (+ space) (submatch (+ numeric))))) ))
 
-(define markov-generate:sre  (irregex '(: "markov" (+ space) (submatch (+ (~ space)))  (? (+ space) (submatch (+ numeric))))))
+;; SREs to match the commands
+(define markov-clear:sre     '(: "markov" (+ space) "clear" (* any)))
+(define markov-stats:sre     '(: "markov" (+ space) "stats" (* any)))
+(define markov-autolearn:sre '(: "markov" (+ space) "autolearn" (+ space) (submatch (or "on" "off")) (* any)))
+(define markov-learn:sre     '(: "markov" (+ space) "learn" (+ space) (submatch (+ any))))
 
+(define markov-quota:sre     '(: "markov" (+ space) "quota" (+ space)  (or (submatch (or "disable" "show")) (: (submatch "set") (+ space) (submatch (+ numeric))))) )
 
-(define (markov-clear:handler m #!rest _)
+(define markov-generate:sre  '(: "free-associate" (+ space) (submatch (+ (~ space)))  (? (+ space) (submatch (+ numeric)))))
+
+
+;; Handlers
+(define (markov-clear:handler m )
   (dictionary-clear! *probabilities*)
   (reply-to m "Aye! Dictionary has been cleared"))
 
         (learn-text! *probabilities* what)
         (reply-to m "Aye! learned that"))))
 
-(define (markov-quota:handler m value)
+(define (markov-quota:handler m disable/show set value)
   (cond
-   ((string=? value "disable")
+   ((and disable/show (string=? disable/show "disable"))
     (set! *quota* #f)
     (reply-to m "Aye! Quota disabled"))
-   ((string=? value "show")
+   ((and disable/show (string=? disable/show "show"))
     (if (number? *quota*)
         (reply-to m (sprintf "Quota is currently set to ~A" *quota*))
         (reply-to m (sprintf "Quota is currently disabled"))))
     (set! *quota* (string->number value))
     (reply-to m (sprintf "Aye! Quota set to ~A" *quota*)))))
 
-(define (markov-generate:handler m trigger . value)
-  (let ((length (if (null? value) 30 (car value))))
+(define (markov-generate:handler m trigger length)
+  (let ((length (or (and (number? length) length) 30)))
     (cond
      ((zero? (dictionary-size *probabilities*))
       (reply-to m "Sorry I don't know anything yet"))
      (else
       (reply-to m (sprintf  "Sorry I don't know anything about ~A" trigger))))))
 
+(define (markov-stats:handler m)
+  (reply-to
+   m
+   (sprintf
+       "Aye! I've learned ~A tokens. Autolearning is ~A. Quota is ~A."
+     (dictionary-size *probabilities*)
+     (if *autolearn* "enabled" "disabled")
+     (or *quota* "disabled"))))
+
 (define (markov-message-handler message)
   (when *autolearn*
     (unless (quota-exceeded?)
-      (learn-text! *probabilities* (message-body message)))))
-
+      (learn-text! *probabilities* (message-body message))))
+  #f)

tests/markov-spec.scm

 (load "../markov-impl.scm")
-(use srfi-1 format)
+(require-extension (except vandusen $))
+(use srfi-1 format random-bsd srfi-69)
 
 
 
       (learn-tokens! ($ 'dict) (list "just" "a" "test"))
       (expect (token-pair-ref ($ 'dict) "just" "a") (be 1.0)))
 
+    (it "learns all unknown tokens"
+      (let ((tokens (list "just" "a" "test")))
+        (learn-tokens! ($ 'dict) tokens)
+        (for-each
+         (lambda (token)
+           (do-not
+            (expect
+                (dictionary-ref ($ 'dict) "just")
+                (be false))))
+         tokens)))
+
     (it "updates known tokens"
       (learn-tokens! ($ 'dict) (list "just" "a" "test" "just" "a"))
       (expect (token-pair-ref ($ 'dict) "just" "a") (be 2.0)))
     (it "generates a sequence"
       (let ((probs (make-dictionary)))
         (learn-text! probs "this is just a test just b foo")
-        (expect (member  (generate-text probs "just" 2)
+        (expect (member  (generate-text probs "just" 3)
                          (list "just b foo" "just a test" "just a test just"))
             (be a list)))))
 
   (context "Commands"
     (context "SREs"
+
+      (it "matches markov stats"
+        (expect markov-stats:sre
+            (match-string "markov   stats")))
+      
       (it "matches markov clear"
         (expect markov-clear:sre
-            (match-string "markov   clear" with-matches: `((1 . "clear")))))
+            (match-string "markov   clear")))
 
       (it "matches markov autolearn on"
         (expect markov-autolearn:sre
 
       (it "matches markov trigger"
         (expect markov-generate:sre
-            (match-string "markov foo" with-matches: '((1 . "foo")))))
+            (match-string "free-associate foo" with-matches: '((1 . "foo")))))
 
       (it "matches markov trigger 30"
         (expect markov-generate:sre
-            (match-string "markov foo 30" with-matches: '((1 . "foo") (2 . "30"))))))
+            (match-string "free-associate foo 30" with-matches: '((1 . "foo") (2 . "30"))))))
 
 
     (context "Execution"
       (before each:
         (set! *probabilities* (make-dictionary)))
+
+      (context "stats"
+
+        (it "reports the learned tokens"
+          (expect
+              (vandusen-answer
+               (markov-autolearn:handler #f "off")
+               (markov-quota:handler #f "disable" #f #f)
+               (markov-stats:handler #f))
+              (be "Aye! I've learned 0 tokens. Autolearning is disabled. Quota is disabled.")))
+
+        (it "reports autolearning on"
+          (expect
+              (vandusen-answer
+               (markov-autolearn:handler #f "on")
+               (markov-quota:handler #f "disable" #f #f)
+               (markov-stats:handler #f))
+              (be "Aye! I've learned 0 tokens. Autolearning is enabled. Quota is disabled.")))
+
+        (it "reports the quota"
+          (expect
+              (vandusen-answer
+               (markov-autolearn:handler #f "on")
+               (markov-quota:handler #f #f "set" "3")
+               (markov-stats:handler #f))
+              (be "Aye! I've learned 0 tokens. Autolearning is enabled. Quota is 3."))))
+
+      
+      
       
       (context "mark clear"
         (it "clears the dictionary"
           (it "doesn't learn when quota is set and exceeded"
             (with-stubbed-reply-to
              (markov-clear:handler #f)
-             (markov-learn:handler #f "just a")
-             (markov-quota:handler #f "2")
+             (markov-learn:handler #f "just a test")
+             (markov-quota:handler #f #f "set" "1")
              (let ((old-size (dictionary-size *probabilities*)))
                (markov-learn:handler #f "another test")
                (expect
         (context "show"
           (it "Shows numeric quota"
             (expect (vandusen-answer
-                     (markov-quota:handler #f "3")
-                     (markov-quota:handler #f "show"))
+                     (markov-quota:handler #f #f "set" "3" )
+                     (markov-quota:handler #f "show" #f #f))
                 (be "Quota is currently set to 3")))
           (it "Shows correct answer when quota is not set"
             (expect (vandusen-answer
-                     (markov-quota:handler #f "disable")
-                     (markov-quota:handler #f "show"))
+                     (markov-quota:handler #f "disable" #f #f)
+                     (markov-quota:handler #f "show" #f #f))
                 (be "Quota is currently disabled")))))
       
       (context "generate"
         (it "answers correctly when nothing has been learned"
           (expect (vandusen-answer
                    (markov-clear:handler #f)
-                   (markov-generate:handler #f "trigger"))
+                   (markov-generate:handler #f "trigger" #f))
               (be "Sorry I don't know anything yet")))
 
         (it "answers correctly when trigger doesn't match"
           (expect (vandusen-answer
                    (markov-clear:handler #f)
                    (markov-learn:handler #f "just a test")
-                   (markov-generate:handler #f "trigger"))
+                   (markov-generate:handler #f "trigger" #f))
               (be "Sorry I don't know anything about trigger"))))
       (it "generates the answer"
           (expect (vandusen-answer
                    (markov-clear:handler #f)
                    (markov-learn:handler #f "just a test")
-                   (markov-generate:handler #f "just"))
+                   (markov-generate:handler #f "just" #f))
               (be "just a test"))))))
 
 

vandusen-markov.import.scm

+;;;; vandusen-markov.import.scm - GENERATED BY CHICKEN 4.7.2 -*- Scheme -*-
+
+(eval '(import
+         chicken
+         scheme
+         srfi-13
+         srfi-1
+         vandusen
+         irc
+         random-bsd
+         srfi-69
+         irregex))
+(##sys#register-compiled-module 'vandusen-markov (list) '() (list) (list))
+
+;; END OF FILE

vandusen-markov.meta

+((egg "vandusen-markov.egg")
+ (author "David Krentzlin")
+ (synopsis "vandusen-plugin to generate text with a markov-chain")
+ (category net)
+ (license "MIT")
+ (doc-from-wiki)
+ (depends vandusen irc random-bsd)
+ (test-depends missbehave)
+ (files "vandusen-markov.scm" "markov-impl.scm" "tests/markov-spec.scm"))

vandusen-markov.scm

 ;; %%HEADER%%
 ;; 
 
-(module vanduse-markov ()
+(module vandusen-markov ()
+(import chicken scheme srfi-13 srfi-1)
 
-(define message-body
-  (let ((rx (irregex '(seq #\: (+ (~ #\:)) #\: (submatch (+ any))))))
-    (lambda (m)
-      (irregex-match-substring (irregex-match rx (irc:message-body m)) 1))))
-
-
-
+(use vandusen irc random-bsd srfi-69 irregex)
+(include "markov-impl.scm")
 (plugin 'markov
         (lambda ()
-          (let ((tokens-seen (make-hash-table string=?))
-                (probabilities (make-hash-table string=?))
-                (autolearn #f)
-                (dictionary-quota #f))
+          (command 'markov-clear  markov-clear:sre markov-clear:handler)
+          (command 'markov-stats  markov-stats:sre markov-stats:handler)
+          (command 'markov-autolearn  markov-autolearn:sre markov-autolearn:handler)
+          (command 'markov-learn  markov-learn:sre markov-learn:handler)
+          (command 'markov-quota  markov-quota:sre markov-quota:handler)
+          (command 'markov-generate markov-generate:sre markov-generate:handler public: #t)
+          (message-handler markov-message-handler command: "PRIVMSG")))
 
-
-            (define (add-tokens! token successor)
-              (unless (hash-table-ref tokens-seen token)
-                (hash-table-set! tokens-seen (make-hash-table string=?)))
-              (let ((next-tokens (hash-table-ref tokens-seen token)))
-                (hash-table-set! next-tokens successor 1.0)))
-
-            (define (update-tokens! token successor)
-              (let* ((text-tokens (hash-table-ref tokens-seen token))
-                     (count       (hash-table-ref next-tokens successor)))
-                (hash-table-set! next-tokens successor (+ count 1.0))))
-
-            (define (tokens-known? token successor)
-              (and-*let ((_  (hash-table-ref tokens-seen token))
-                         (__ (hash-table-ref _ successor)))
-                        #t))
-            
-            (define (learn-tokens! tokens)
-              (for-each-token-with-successor
-               (lambda (token successor)
-                 (unless (hash-table-ref dictionary token)
-                   (hash-table-set! tokens-seen token (make-hash-table string=?)))
-              
-                 (when successor
-                   (if (not (tokens-known? token successor))
-                       (add-tokens! token successor)
-                       (update-tokens! token successor))))
-               tokens))
-
-            (define (update-probability! tokens)
-              (hash-table-clear! probabilities)
-              (hash-table-for-each
-               tokens-seen
-               (lambda (token successors)
-                 (let ((total (sum (hash-table-values successors)))
-                       (probs (make-hash-table string=?)))
-                   (hash-table-for-each
-                    successors
-                    (lambda (next_token count)
-                      (hash-table-set! pobs next_token (/ count total))))
-                   (hash-table-set! probabilities token probs)))))
-
-            (define (learn-text text)
-              (let ((tokens    (tokenize-text text)))
-                (learn-tokens! tokens)
-                (update-probability!)))
-
-            (define (generate-text trigger length) #t)
-
-            (define (!markov-clear m . rest)
-              (hash-table-clear! tokens-seen)
-              (hash-table-clear! probabilities))
-
-            (define (!markov-auto-learn m mode)
-              (cond
-               ((string=? mode "on")
-                (set! autolearn #t)
-                (reply-to m "autolearning enabled"))
-               ((string=? mode "off")
-                (set! autolearn #f)
-                (reply-to m "autolearning disabled"))
-               (else (reply-to m "I don't understand"))))
-
-            (command 'markov-clear
-                     '(: "markov" (+ space) "clear")
-                     (lambda (m . rest)
-                       (hash-table-clear! dictionary)
-                       (reply-to m (format "Dictionary has been cleared"))))
-
-            (command 'markov-auto-learn
-                     '(: "markov" (+ space) "autolearn" (+ space) (submatch (or "on" "off")))
-              )
-
-            (command 'markov-learn
-                     '(: "markov" (+ space) "learn" (+ any))
-                     (lambda (m text)
-                       (if (dictionary-quota-exceeded?)
-                         (reply-to m "Sorry. Could not learn, because the dictionary quota is exceeded")
-                         (begin
-                           (learn-text text)
-                           (reply-to m "Aye!")))))
-
-            (command 'marko-set-quota
-                     '(: "markov" (+ space) "quota" (submatch (or "disabled" "show"  (+ numeric))))
-                     (lambda (m value)
-                       (cond
-                        ((string=? value "disabled")
-                         (set! dictionary-quota #f)
-                         (reply-to m "Disabled dictionary quota"))
-                        ((string=? value "show")
-                         (if (number? dictionary-quota)
-                             (reply-to m "Dictionary quota is currently set to ~A" dictionary-quota)
-                             (reply-to m "Dictionary quota is currently disabled")))
-                        (else
-                         (set! dictionary-quota (string->number value))
-                         (reply-to m (format "Aye! Set dictionary quota to ~A" value))))))
-
-            (command 'markov-say
-                     '(: "markov" (+ (~ space))  (? (+ space) (submatch (+ numeric))))
-                     (lambda (m trigger . value)
-                       (let ((length (if (null? value) 30 (car value))))
-                         (reply-to m (generate-text trigger length)))))
-
-            (message-handler (lambda (message)
-                               (when autolearn
-                                 (unless (dictionary-quota-exceeded?)
-                                   (learn-text (message-body m))))))))))
+)

vandusen-markov.setup

+(compile -s -O2 -d0  vandusen-markov.scm -j vandusen-markov)
+(compile -s -O2 -d0  vandusen-markov.import.scm)
+
+(install-extension
+  'vandusen-markov
+  '("vandusen-markov.import.so" "vandusen-markov.so")
+  '((version 1.0)))