Commits

David Krentzlin committed dd6045d

implemented basic functionality. Need to find a way to describe the behaviour of the commands.

Comments (0)

Files changed (2)

 ;; 
 ;; %%HEADER%%
-;; 
+;;
+
+(use random-bsd)
 
 (define message-body
   (let ((rx (irregex '(seq #\: (+ (~ #\:)) #\: (submatch (+ any))))))
 (define (dictionary-ref dict key #!optional (default #f))
   (hash-table-ref/default dict key default))
 (define dictionary-values hash-table-values)
+(define (dictionary-for-each proc dict)
+  (hash-table-for-each dict proc))
+(define dictionary-clear! hash-table-clear!)
 
 
 (define (learn-tokens! dict token-list)
              (__ (dictionary-ref _ successor)))
             #t))
 
-(define (learn-token-pair! dict token successor)
+(define (learn-token-pair! dict token successor #!optional (value 1.0))
   (unless (dictionary-ref dict token)
     (dictionary-set! dict token (make-dictionary)))
   (let ((successors (dictionary-ref dict token)))
-    (dictionary-set! successors successor 1.0)))
+    (dictionary-set! successors successor value)))
 
 (define (update-token-pair! dict token successor)
   (and-let* ((successors (dictionary-ref dict token))
 
 (define (tokenize-input input)
   (irregex-split '(: (+ space)) input))
+
+(define (update-probabilities! probs dict)
+  (dictionary-for-each
+   (lambda (token successors)
+     (let ((total-successors (fold + 0 (dictionary-values successors))))
+       (dictionary-for-each
+        (lambda (successor value)
+          (learn-token-pair! probs token successor (/ value total-successors)))
+        successors)))
+   dict))
+
+(define (probability-for probs token successor)
+  (or (token-pair-ref probs token successor) 0.0))
+
+(define (learn-text! probs text)
+  (let ((dict (make-dictionary))
+        (tokens (tokenize-input text)))
+    (unless (null? tokens)
+      (dictionary-clear! probs)
+      (learn-tokens! dict tokens)
+      (update-probabilities! probs dict)
+      probs)))
+
+(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))))))
+
+(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))))))
+
+
+
+(define (cleanup-text text)
+  (or (irregex-replace "([!.?]).*$" text 1)
+      text))
+
+
+(plugin 'markov
+        (lambda ()
+          (receive (markov-command-handler markov-message-handler) (markov-init)
+            (for-each
+             (lambda (handler-id)
+               (apply command (markov-command-handler handler-id)))
+             (markov-available-handlers))
+            (message-handler markov-message-handler))))
+
+

tests/markov-spec.scm

 
            (it "updates known tokens"
                (learn-tokens! ($ 'dict) (list "just" "a" "test" "just" "a"))
-               (expect (token-pair-ref ($ 'dict) "just" "a") (be 2.0)))))
+               (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))))
+
+           (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 "!" "?" "."))
+
+                    
+                    (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))))))
+
+