Commits

David Krentzlin committed dca3e01

implemented most actions

  • Participants
  • Parent commits da0b6d0

Comments (0)

Files changed (2)

 (use random-bsd vandusen irc)
 
 
-
+;;some options
+(define *autolearn* #f)
+(define *quota*     #f)
 
 (define message-body
   (let ((rx (irregex '(seq #\: (+ (~ #\:)) #\: (submatch (+ any))))))
 (define (dictionary-for-each proc dict)
   (hash-table-for-each dict proc))
 (define dictionary-clear! hash-table-clear!)
+(define dictionary-size hash-table-size)
+
+
 
 (define *probabilities* (make-dictionary))
 
 (define (learn-tokens! dict token-list)
   (for-each-token-pair
    (lambda (token successor)
-     (when successor
+     (if successor
        (if (not (token-pair-known? dict token successor))
            (learn-token-pair! dict token successor)
-           (update-token-pair! dict token successor))))
+           (update-token-pair! dict token successor))
+       (dictionary-set! dict token (make-dictionary))))
    token-list))
 
 (define (for-each-token-pair proc list-of-tokens)
 
 (define (generate-text probs trigger #!optional (length 30))
   (and (dictionary-ref probs trigger)
-       (let loop ((text (list)) (words-left length) (trigger trigger))
-         (if (not (positive? words-left))
-             (cleanup-text (string-join (reverse  text)))
-             (let ((next-word (next-best-successor probs trigger)))
-               (loop (cons next-word text ) (- words-left 1) next-word))))))
+       (let loop ((text (list trigger)) (words-left length) (trigger trigger))
+         (cond
+          ((not (positive? words-left))
+           (cleanup-text (string-join (reverse  text))))
+          ((next-best-successor probs trigger)
+           => (lambda (next-word)
+                (loop (cons next-word text) (- words-left 1) next-word)))
+          (else (cleanup-text (string-join (reverse text))))))))
 
 (define (next-best-successor probs trigger)
   (let ((r       (random-real))
         (probsum 0.0))
     (call-with-current-continuation
      (lambda (return)
-       (dictionary-for-each
-        (lambda (successor prob)
-          (when (and (>= r probsum) (< r (+ probsum prob)))
-            (return successor))
-          (set! probsum (+ probsum prob)))
-        (dictionary-ref probs trigger))))))
+       (let ((successors (dictionary-ref probs trigger)))
+         (unless successors
+           (return #f))
+         (dictionary-for-each
+          (lambda (successor prob)
+            (when (and (>= r probsum) (< r (+ probsum prob)))
+              (return successor))
+            (set! probsum (+ probsum prob)))
+          successors)
+         #f)))))
 
 (define (cleanup-text text)
   (or (irregex-replace "([!.?]).*$" text 1)
       text))
 
 
-(define (!markov-clear m #!rest _)
+(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))))))
+
+
+(define (markov-clear:handler m #!rest _)
   (dictionary-clear! *probabilities*)
   (reply-to m "Aye! Dictionary has been cleared"))
 
+(define (markov-autolearn:handler m mode)
+  (cond
+   ((string=? mode "on")
+    (set! *autolearn* #t)
+    (reply-to m "Aye! autolearning enabled"))
+   ((string=? mode "off")
+    (set! *autolearn* #f)
+    (reply-to m "Aye! autolearning disabled"))
+   (else (reply-to m "I don't understand"))))
+
+(define (markov-learn:handler m what)
+  (if (quota-exceeded?)
+      (reply-to m "Sorry, can not learn anymore. Quota exceeded")
+      (begin
+        (learn-text! *probabilities* what)
+        (reply-to m "Aye! learned that"))))
+
+(define (markov-quota:handler m value)
+  (cond
+   ((string=? value "disable")
+    (set! *quota* #f)
+    (reply-to m "Aye! Quota disabled"))
+   ((string=? value "show")
+    (if (number? *quota*)
+        (reply-to m (sprintf "Quota is currently set to ~A" *quota*))
+        (reply-to m (sprintf "Quota is currently disabled"))))
+   (else
+    (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))))
+    (cond
+     ((zero? (dictionary-size *probabilities*))
+      (reply-to m "Sorry I don't know anything yet"))
+     ((generate-text *probabilities* trigger length)
+      => (lambda (text) (reply-to m text)))
+     (else
+      (reply-to m (sprintf  "Sorry I don't know anything about ~A" trigger))))))
+
+(define (markov-message-handler message)
+  (when *autolearn*
+    (unless (quota-exceeded?)
+      (learn-text! *probabilities* (message-body message)))))
+

tests/markov-spec.scm

                                           (sprintf "Expected ~A to match ~S" form what)))))))
 
 
+
+(define-syntax vandusen-answer
+  (syntax-rules ()
+    ((_ code more-code ...)
+     (let ((last-answer ""))
+       (with-stubs! ((vandusen#reply-to (lambda (m msg) (set! last-answer msg))))
+         (begin
+           code more-code ...)
+         last-answer)))))
+
+(define-syntax with-stubbed-reply-to
+  (syntax-rules ()
+    ((_ code more-code ...)
+     (with-stubs! ((vandusen#reply-to (returns #t)))
+       code more-code ...))))
+
+
 (context "Markov"
   (before each:
-          (set! ($ 'dict) (make-dictionary))
-          (subject-set! ($ 'dict)))
+    (set! ($ 'dict) (make-dictionary))
+    (subject-set! ($ 'dict)))
   
   (context "Dictionary"
-           (it should (be a dictionary))
-           
-           (it "returns #f if one wants to retrieve a value from an empty dictonary"
-               (expect (dictionary-ref ($' dict) "key") (be false)))
+    (it should (be a dictionary))
+    
+    (it "returns #f if one wants to retrieve a value from an empty dictonary"
+      (expect (dictionary-ref ($' dict) "key") (be false)))
 
-           (it "returns value if it exists in the dictionary"
-               (dictionary-set! ($ 'dict) "key" "value")
-               (expect (dictionary-ref ($  'dict) "key") (be "value")))
-           
-           (it "returns #f if the given key does not exist in the dictionary"
-               (dictionary-set! ($ 'dict) "key" "value")
-               (expect (dictionary-ref ($ 'dict) "key2") (be false)))
-           
-           (it "replaces the value of a key if inserted multiple times"
-               (dictionary-set! ($ 'dict) "key" "value1")
-               (expect (dictionary-ref ($ 'dict)  "key") (be "value1"))
-               (dictionary-set! ($ 'dict) "key" "value2")
-               (expect (dictionary-ref ($ 'dict) "key") (be "value2")))
-           
-           (it "returns a list of values"
-               (dictionary-set! ($ 'dict) "key" "value")
-               (dictionary-set! ($ 'dict) "key1" "value1")
-               (dictionary-set! ($ 'dict) "key2" "value2")
-               (expect (lset= string-ci=? (dictionary-values ($ 'dict)) (list "value" "value1" "value2"))
-                       (be true))))
+    (it "returns value if it exists in the dictionary"
+      (dictionary-set! ($ 'dict) "key" "value")
+      (expect (dictionary-ref ($  'dict) "key") (be "value")))
+    
+    (it "returns #f if the given key does not exist in the dictionary"
+      (dictionary-set! ($ 'dict) "key" "value")
+      (expect (dictionary-ref ($ 'dict) "key2") (be false)))
+    
+    (it "replaces the value of a key if inserted multiple times"
+      (dictionary-set! ($ 'dict) "key" "value1")
+      (expect (dictionary-ref ($ 'dict)  "key") (be "value1"))
+      (dictionary-set! ($ 'dict) "key" "value2")
+      (expect (dictionary-ref ($ 'dict) "key") (be "value2")))
+    
+    (it "returns a list of values"
+      (dictionary-set! ($ 'dict) "key" "value")
+      (dictionary-set! ($ 'dict) "key1" "value1")
+      (dictionary-set! ($ 'dict) "key2" "value2")
+      (expect (lset= string-ci=? (dictionary-values ($ 'dict)) (list "value" "value1" "value2"))
+          (be true))))
 
   (context "Tokenize input"
-           (let ((expected (list "just" "a" "test")))
-             (it "splits on space"
-                 (expect (tokenize-input "just a    test")
-                         (be expected)))
-             (it "splits on tabs"
-                 (expect (tokenize-input (format #f "just ~T a test"))
-                         (be expected)))
-             
-             (it "splits on newline"
-                 (expect (tokenize-input (format #f "just ~% a test"))
-                         (be expected)))))
+    (let ((expected (list "just" "a" "test")))
+      (it "splits on space"
+        (expect (tokenize-input "just a    test")
+            (be expected)))
+      (it "splits on tabs"
+        (expect (tokenize-input (format #f "just ~T a test"))
+            (be expected)))
+      
+      (it "splits on newline"
+        (expect (tokenize-input (format #f "just ~% a test"))
+            (be expected)))))
 
   (context "Learning"
-           (it "learns unknown token"
-               (learn-tokens! ($ 'dict) (list "just" "a" "test"))
-               (expect (token-pair-ref ($ 'dict) "just" "a") (be 1.0)))
+    (it "learns unknown token"
+      (learn-tokens! ($ 'dict) (list "just" "a" "test"))
+      (expect (token-pair-ref ($ 'dict) "just" "a") (be 1.0)))
 
-           (it "updates known tokens"
-               (learn-tokens! ($ 'dict) (list "just" "a" "test" "just" "a"))
-               (expect (token-pair-ref ($ 'dict) "just" "a") (be 2.0)))
+    (it "updates known tokens"
+      (learn-tokens! ($ 'dict) (list "just" "a" "test" "just" "a"))
+      (expect (token-pair-ref ($ 'dict) "just" "a") (be 2.0)))
 
 
-           (context "Probabilities"
-             (before each:
-                     (set! ($ 'probs) (make-dictionary)))
-             
-             (it "handles unknown tokens"
-                 (expect (probability-for ($ 'probs) "dont" "exist")
-                         (be 0.0)))
-             
-             (it "updates probabilities"
-                 (learn-tokens! ($ 'dict) (list "just" "a" "test" "just" "b"))
-                 (update-probabilities! ($ 'probs) ($ 'dict))
-                 (expect (probability-for ($ 'probs) "just" "a")
-                         (be .5))))
+    (context "Probabilities"
+      (before each:
+        (set! ($ 'probs) (make-dictionary)))
+      
+      (it "handles unknown tokens"
+        (expect (probability-for ($ 'probs) "dont" "exist")
+            (be 0.0)))
+      
+      (it "updates probabilities"
+        (learn-tokens! ($ 'dict) (list "just" "a" "test" "just" "b"))
+        (update-probabilities! ($ 'probs) ($ 'dict))
+        (expect (probability-for ($ 'probs) "just" "a")
+            (be .5))))
 
-           (it "learns from a text"
-               (let ((probs (make-dictionary)))
-                 (learn-text! probs "this is just a test")
-                 (expect (probability-for probs "just" "a")
-                         (be 1.0)))))
+    (it "learns from a text"
+      (let ((probs (make-dictionary)))
+        (learn-text! probs "this is just a test")
+        (expect (probability-for probs "just" "a")
+            (be 1.0)))))
 
   (context "Text generation"
-           (before each:
-                   (set! ($ 'probs) (make-dictionary)))
-           
-           (context "cleanup"
-                    (for-each (lambda (mark)
-                                (it (sprintf "strips half sentences ending in ~A" mark)
-                                    (expect (cleanup-text (sprintf "just a test~A with some" mark))
-                                            (be (sprintf "just a test~A" mark)))))
-                              (list "!" "?" "."))
+    (before each:
+      (set! ($ 'probs) (make-dictionary)))
+    
+    (context "cleanup"
+      (for-each
+       (lambda (mark)
+         (it (sprintf "strips half sentences ending in ~A" mark)
+           (expect (cleanup-text (sprintf "just a test~A with some" mark))
+               (be (sprintf "just a test~A" mark)))))
+       (list "!" "?" "."))
+      
+      
+      (it "just returns the text if no sentences can be found"
+        (expect (cleanup-text "just a test")
+            (be "just a test"))))
+    
+    (it "returns false if now generation can be instantiated"
+      (expect (generate-text ($ 'probs) "test")
+          (be false)))
+    
+    (it "stops generation if no continuation can be found"
+      (let ((probs (make-dictionary)))
+        (learn-text! probs "this is just a test justin time")
+        (expect
+            (generate-text probs "just" 20)
+            (be "just a test justin time"))))
 
-                    
-                    (it "just returns the text if no sentences can be found"
-                        (expect (cleanup-text "just a test")
-                                (be "just a test"))))
-           (it "returns false if now generation can be instantiated"
-               (expect (generate-text ($ 'probs) "test")
-                       (be false)))
-
-           (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)
-                                  (list "b foo" "a test"))
-                         (be a list)))))
+    (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")
+                         (list "just b foo" "just a test"))
+            (be a list)))))
 
   (context "Commands"
-           (context "SREs"
-                    (it "matches markov clear"
-                        (expect '(: "markov" (+ space) (submatch "clear") (* any))
-                                (match-string "markov   clear" with-matches: `((1 . "clear")))))
+    (context "SREs"
+      (it "matches markov clear"
+        (expect markov-clear:sre
+            (match-string "markov   clear" with-matches: `((1 . "clear")))))
 
+      (it "matches markov autolearn on"
+        (expect markov-autolearn:sre
+            (match-string "markov autolearn on" with-matches: `((1 . "on")))))
 
-                    (let ((sre  '(: "markov" (+ space) "autolearn" (+ space) (submatch (or "on" "off")) (* any))))
-                      (it "matches markov autolearn on"
-                          (expect sre
-                                  (match-string "markov autolearn on" with-matches: `((1 . "on")))))
+      (it "matches markov autolearn off"
+        (expect markov-autolearn:sre
+            (match-string "markov autolearn off" with-matches: `((1 . "off")))))
 
-                      (it "matches markov autolearn off"
-                          (expect sre
-                                  (match-string "markov autolearn off" with-matches: `((1 . "off")))))
+      (it "matches markov learn"
+        (expect  markov-learn:sre
+            (match-string "markov learn just a test"
+                          with-matches: '((1 . "just a test")))))
 
-                      (it "matches markov learn"
-                          (expect  '(: "markov" (+ space) "learn" (+ space) (submatch (+ any)))
-                                   (match-string "markov learn just a test"
-                                                 with-matches: '((1 . "just a test"))))))
+      
+      (it "matches markov quota show"
+        (expect markov-quota:sre
+            (match-string "markov quota show" with-matches: '((1 . "show")))))
 
-                    (let ((sre '(: "markov" (+ space) "quota" (+ space)  (or (submatch (or "disable" "show")) (: (submatch "set") (+ space) (submatch (+ numeric))))) ))
-                    
-                      (it "matches markov quota show"
-                          (expect sre
-                                  (match-string "markov quota show" with-matches: '((1 . "show")))))
+      (it "matches markov quota disable"
+        (expect markov-quota:sre
+            (match-string "markov quota disable" with-matches: '((1 . "disable")))))
+      
+      (it "matches markov quota set x"
+        (expect markov-quota:sre
+            (match-string "markov quota set 1" with-matches: '((2 . "set") (3 . "1")))))
 
-                      (it "matches markov quota disable"
-                          (expect sre
-                                  (match-string "markov quota disable" with-matches: '((1 . "disable")))))
-                    
-                      (it "matches markov quota set x"
-                          (expect sre
-                                  (match-string "markov quota set 1" with-matches: '((2 . "set") (3 . "1"))))))
 
+      (it "matches markov trigger"
+        (expect markov-generate:sre
+            (match-string "markov foo" with-matches: '((1 . "foo")))))
 
-                    (let ((sre '(: "markov" (+ space) (submatch (+ (~ space)))  (? (+ space) (submatch (+ numeric))))))
-                      (it "matches markov trigger"
-                          (expect sre
-                                  (match-string "markov 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"))))))
 
-                      (it "matches markov trigger 30"
-                          (expect sre
-                                  (match-string "markov foo 30" with-matches: '((1 . "foo") (2 . "30")))))))
 
+    (context "Execution"
+      (before each:
+        (set! *probabilities* (make-dictionary)))
+      
+      (context "mark clear"
+        (it "clears the dictionary"
+          (with-stubbed-reply-to
+           (dictionary-set! *probabilities* "foo" 1)
+           (markov-clear:handler "test")
+           (expect (dictionary-ref *probabilities* "foo") (be false))))
+        
+        (it "answers as expected"
+          (expect
+              (vandusen-answer (markov-clear:handler #f))
+              (be "Aye! Dictionary has been cleared"))))
+      
+      
+      (context "auto learn"
 
-           (context "Execution"
-                    (before each:
-                            (set! *probabilities* (make-dictionary)))
-                    
-                    (let ((last-answer ""))                      
-                      (context "mark clear"
-                               (it "clears the dictionary"
-                                   (with-stubs! ((vandusen#reply-to (lambda (m txt) (set! last-answer txt))))
-                                      (dictionary-set! *probabilities* "foo" 1)
-                                      (!markov-clear "test")
-                                      (expect (dictionary-ref *probabilities* "foo") (be false))))
+        (it "learns new tokens when enabled"
+          (with-stubbed-reply-to
+           (with-stubs! ((message-body identity))
+             (markov-clear:handler #f)
+             (markov-autolearn:handler #f "on")
+             (markov-message-handler "just a test")
+             (expect (dictionary-ref *probabilities* "just") (be a dictionary)))))
 
-                               (it "answers as expected"
-                                   (with-stubs! ((vandusen#reply-to (lambda (m txt) (set! last-answer txt))))
-                                     (!markov-clear "test")
-                                     (expect last-answer (be "Aye! Dictionary has been cleared")))))
+        (it "doesn't learn new tokens when disabled"
+          (with-stubbed-reply-to
+           (with-stubs! ((message-body identity))
+             (markov-clear:handler #f)
+             (markov-autolearn:handler #f "off")
+             (markov-message-handler "just a test")
+             (expect
+                 (dictionary-ref *probabilities* "just")
+                 (be false)))))
 
+        (it "informs the user when enabled"
+          (expect (vandusen-answer (markov-autolearn:handler #f "on"))
+              (be "Aye! autolearning enabled")))
 
-                      (context "auto learn"
-                               (context "with quota"))
-                      
-                      (context "learn"
-                               (context "with quota"))
-                      
-                      (context "set quota")
-                      (context "generate")
-                      (context "message-handler")
+        (it "informs the user when disabled"
+          (expect
+              (vandusen-answer (markov-autolearn:handler #f "off"))
+              (be "Aye! autolearning disabled")))
+        
+        (context "with quota"
+          (it "doesn't learn new tokens when autolearn is enabled but quota is exceeded"
+            (with-stubbed-reply-to
+             (with-stubs! ((message-body identity)
+                           (quota-exceeded? (returns #t)))
+               (markov-clear:handler #f)
+               (markov-autolearn:handler #f "on")
+               (markov-message-handler "just a test")
+               (expect
+                   (dictionary-size *probabilities*)
+                   (be 0)))))))
+      (context "learn"
+        (it "learns a specific sentence"
+          (with-stubbed-reply-to
+           (markov-clear:handler #f)
+           (markov-learn:handler #f "just a test")
+           (expect
+               (dictionary-size *probabilities*)
+               (be > 0))))
 
-                      ))))
+        (it "answers correctly"
+          (with-stubs! ((quota-exceeded? (returns #f)))
+            (expect
+                (vandusen-answer
+                 (markov-learn:handler #f "just a test"))
+                (be "Aye! learned that"))))
+        
+        (context "with quota"
+          (it "doesn't learn when quotas are exceeded"
+            (with-stubbed-reply-to
+             (with-stubs! ((quota-exceeded? (returns  #t)))
+               (markov-clear:handler #f)
+               (markov-learn:handler #f "just a test")
+               (expect
+                   (dictionary-size *probabilities*)
+                   (be 0)))))
+          
+          (it "informs the user that quotaes are exceeded"
+            (with-stubs! ((quota-exceeded? (returns #t)))
+              (expect
+                  (vandusen-answer
+                   (markov-learn:handler #f "just a test"))
+                  (be "Sorry, can not learn anymore. Quota exceeded"))))))
+      
+      (context "quota"
+        (context "set"
+          (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")
+             (let ((old-size (dictionary-size *probabilities*)))
+               (markov-learn:handler #f "another test")
+               (expect
+                   (dictionary-size *probabilities*)
+                   (be old-size))))))
 
+        (context "show"
+          (it "Shows numeric quota"
+            (expect (vandusen-answer
+                     (markov-quota:handler #f "3")
+                     (markov-quota:handler #f "show"))
+                (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"))
+                (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"))
+              (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"))
+              (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"))
+              (be "just a test")))
+      (context "message-handler")
+      
+      )))
+
+