Markov chains with custom degrees

bach-notes.rkt

#lang racket/base
(require rsound)
(require rsound/piano-tones)
(require racket/list)
(require "markov.rkt")

;; a note is (make-note note-num frames frames)
(define-struct note (pitch time duration))

(define (note->note* old)
  (cons (note-pitch old) (note-duration old)))

(define (notes->note*s old)
  (cond [(empty? old) empty]
        [(equal? (note-duration (first old)) 17640)
         (notes->note*s (rest old))]
        [else
         (cons (note->note* (first old))
               (notes->note*s (rest old)))]))

(define bach-notes
  (notes->note*s
  (list (make-note 60 8820 8820)
(make-note 62 17640 8820)
(make-note 64 26460 8820)
(make-note 65 35280 8820)
(make-note 62 44100 8820)
(make-note 64 52920 8820)
(make-note 60 61740 8820)
(make-note 67 70560 17640)
(make-note 48 79380 8820)
(make-note 72 88200 17640)
(make-note 50 88200 8820)
(make-note 52 97020 8820)
(make-note 72 105840 2940)
(make-note 53 105840 8820)
(make-note 71 108780 2940)
(make-note 72 111720 2940)
(make-note 71 114660 8820)
(make-note 50 114660 8820)
(make-note 72 123480 17640)
(make-note 52 123480 8820)
(make-note 48 132300 8820)
(make-note 74 141120 8820)
(make-note 55 141120 17640)
(make-note 67 149940 8820)
(make-note 69 158760 8820)
(make-note 43 158760 17640)
(make-note 71 167580 8820)
(make-note 72 176400 8820)
(make-note 69 185220 8820)
(make-note 71 194040 8820)
(make-note 67 202860 8820)
(make-note 74 211680 17640)
(make-note 55 220500 8820)
(make-note 79 229320 17640)
(make-note 57 229320 8820)
(make-note 59 238140 8820)
(make-note 79 246960 2940)
(make-note 60 246960 8820)
(make-note 77 249900 2940)
(make-note 79 252840 2940)
(make-note 77 255780 8820)
(make-note 57 255780 8820)
(make-note 79 264600 17640)
(make-note 59 264600 8820)
(make-note 55 273420 8820)
(make-note 76 282240 8820)
(make-note 60 282240 17640)
(make-note 81 291060 8820)
(make-note 79 299880 8820)
(make-note 59 299880 17640)
(make-note 77 308700 8820)
(make-note 76 317520 8820)
(make-note 60 317520 17640)
(make-note 79 326340 8820)
(make-note 77 335160 8820)
(make-note 62 335160 17640)
(make-note 81 343980 8820)
(make-note 79 352800 8820)
(make-note 64 352800 17640)
(make-note 77 361620 8820)
(make-note 76 370440 8820)
(make-note 55 370440 17640)
(make-note 74 379260 8820)
(make-note 72 388080 8820)
(make-note 57 388080 17640)
(make-note 76 396900 8820)
(make-note 74 405720 8820)
(make-note 59 405720 17640)
(make-note 77 414540 8820)
(make-note 76 423360 8820)
(make-note 60 423360 17640)
(make-note 74 432180 8820)
(make-note 72 441000 8820)
(make-note 52 441000 17640)
(make-note 71 449820 8820)
(make-note 69 458640 8820)
(make-note 54 458640 17640)
(make-note 72 467460 8820)
(make-note 71 476280 8820)
(make-note 55 476280 17640)
(make-note 74 485100 8820)
(make-note 72 493920 8820)
(make-note 57 493920 17640)
(make-note 71 502740 8820)
(make-note 69 511560 8820)
(make-note 59 511560 17640)
(make-note 67 520380 8820)
(make-note 66 529200 8820)
(make-note 60 529200 42630)
(make-note 69 538020 8820)
(make-note 67 546840 8820)
(make-note 71 555660 8820)
(make-note 69 564480 17640)
(make-note 50 573300 8820)
(make-note 62 582120 17640)
(make-note 52 582120 8820)
(make-note 54 590940 8820)
(make-note 72 599760 4410)
(make-note 55 599760 8820)
(make-note 71 604170 4410)
(make-note 72 608580 17640)
(make-note 52 608580 8820)
(make-note 54 617400 8820)
(make-note 74 626220 8820)
(make-note 50 626220 8820)
(make-note 71 635040 8820)
(make-note 55 635040 17640)
(make-note 69 643860 8820)
(make-note 67 652680 8820)
(make-note 47 652680 17640)
(make-note 66 661500 8820)
(make-note 64 670320 8820)
(make-note 48 670320 17640)
(make-note 67 679140 8820)
(make-note 66 687960 8820)
(make-note 50 687960 17640)
(make-note 69 696780 8820)
(make-note 67 705600 8820)
(make-note 52 705600 17640)
(make-note 71 714420 8820)
(make-note 69 723240 8820)
(make-note 54 723240 17640)
(make-note 72 732060 8820)
(make-note 71 740880 8820)
(make-note 55 740880 17640)
(make-note 74 749700 8820)
(make-note 72 758520 8820)
(make-note 52 758520 17640)
(make-note 76 767340 8820)
(make-note 74 776160 8820)
(make-note 47 776160 26460)
(make-note 71 784980 4410)
(make-note 72 789390 4410)
(make-note 74 793800 8820)
(make-note 79 802620 8820)
(make-note 48 802620 8820)
(make-note 72 811440 2940)
(make-note 50 811440 17640)
(make-note 71 814380 2940)
(make-note 72 817320 2940)
(make-note 71 820260 8820)
(make-note 69 829080 8820)
(make-note 38 829080 17640)
(make-note 67 837900 8820)
(make-note 67 846720 17640)
(make-note 43 855540 8820)
(make-note 45 864360 8820)
(make-note 47 873180 8820)
(make-note 48 882000 8820)
(make-note 45 890820 8820)
(make-note 47 899640 8820)
(make-note 43 908460 8820)
(make-note 50 917280 17640)
(make-note 67 926100 8820)
(make-note 69 934920 8820)
(make-note 55 934920 17640)
(make-note 71 943740 8820)
(make-note 72 952560 8820)
(make-note 54 952560 17640)
(make-note 69 961380 8820)
(make-note 71 970200 8820)
(make-note 55 970200 17640)
(make-note 67 979020 8820)
(make-note 67 987840 2940)
(make-note 57 987840 8820)
(make-note 66 990780 2940)
(make-note 67 993720 2940)
(make-note 66 996660 8820)
(make-note 50 996660 8820)
(make-note 52 1005480 8820)
(make-note 54 1014300 8820)
(make-note 55 1023120 8820)
(make-note 52 1031940 8820)
(make-note 54 1040760 8820)
(make-note 50 1049580 8820)
(make-note 57 1058400 17640)
(make-note 69 1067220 8820)
(make-note 71 1076040 8820)
(make-note 62 1076040 17640)
(make-note 72 1084860 8820)
(make-note 74 1093680 8820)
(make-note 60 1093680 17640)
(make-note 71 1102500 8820)
(make-note 72 1111320 8820)
(make-note 62 1111320 17640)
(make-note 69 1120140 8820)
(make-note 71 1128960 17640)
(make-note 55 1128960 8820)
(make-note 67 1137780 8820)
(make-note 65 1146600 8820)
(make-note 64 1155420 8820)
(make-note 62 1164240 8820)
(make-note 65 1173060 8820)
(make-note 64 1181880 8820)
(make-note 67 1190700 8820)
(make-note 65 1199520 17640)
(make-note 74 1208340 8820)
(make-note 72 1217160 8820)
(make-note 64 1217160 17640)
(make-note 71 1225980 8820)
(make-note 69 1234800 8820)
(make-note 65 1234800 17640)
(make-note 72 1243620 8820)
(make-note 71 1252440 8820)
(make-note 62 1252440 17640)
(make-note 74 1261260 8820)
(make-note 72 1270080 17640)
(make-note 64 1270080 8820)
(make-note 69 1278900 8820)
(make-note 67 1287720 8820)
(make-note 65 1296540 8820)
(make-note 64 1305360 8820)
(make-note 67 1314180 8820)
(make-note 65 1323000 8820)
(make-note 69 1331820 8820)
(make-note 67 1340640 17640)
(make-note 76 1349460 8820)
(make-note 74 1358280 8820)
(make-note 65 1358280 17640)
(make-note 72 1367100 8820)
(make-note 71 1375920 8820)
(make-note 67 1375920 17640)
(make-note 74 1384740 8820)
(make-note 73 1393560 8820)
(make-note 64 1393560 17640)
(make-note 76 1402380 8820)
(make-note 74 1411200 17640)
(make-note 65 1411200 8820)
(make-note 70 1420020 8820)
(make-note 73 1428840 17640)
(make-note 69 1428840 8820)
(make-note 67 1437660 8820)
(make-note 74 1446480 17640)
(make-note 65 1446480 8820)
(make-note 69 1455300 8820)
(make-note 76 1464120 17640)
(make-note 67 1464120 8820)
(make-note 70 1472940 8820)
(make-note 77 1481760 17640)
(make-note 69 1481760 8820)
(make-note 67 1490580 8820)
(make-note 69 1499400 17640)
(make-note 65 1499400 8820)
(make-note 64 1508220 8820)
(make-note 71 1517040 17640)
(make-note 62 1517040 8820)
(make-note 65 1525860 8820)
(make-note 73 1534680 17640)
(make-note 64 1534680 8820)
(make-note 67 1543500 8820)
(make-note 74 1552320 17640)
(make-note 65 1552320 8820)
(make-note 64 1561140 8820)
(make-note 66 1569960 17640)
(make-note 62 1569960 8820)
(make-note 60 1578780 8820)
(make-note 68 1587600 17640)
(make-note 59 1587600 8820)
(make-note 62 1596420 8820)
(make-note 69 1605240 17640)
(make-note 60 1605240 8820)
(make-note 64 1614060 8820)
(make-note 71 1622880 17640)
(make-note 62 1622880 8820)
(make-note 60 1631700 8820)
(make-note 72 1640520 17640)
(make-note 59 1640520 8820)
(make-note 57 1649340 8820)
(make-note 74 1658160 44100)
(make-note 56 1658160 8820)
(make-note 59 1666980 8820)
(make-note 57 1675800 8820)
(make-note 60 1684620 8820)
(make-note 59 1693440 17640)
(make-note 64 1702260 8820)
(make-note 66 1711080 8820)
(make-note 52 1711080 17640)
(make-note 68 1719900 8820)
(make-note 69 1728720 8820)
(make-note 62 1728720 4410)
(make-note 60 1733130 4410)
(make-note 66 1737540 8820)
(make-note 62 1737540 17640)
(make-note 68 1746360 8820)
(make-note 64 1755180 8820)
(make-note 64 1755180 8820)
(make-note 76 1764000 8820)
(make-note 60 1764000 8820)
(make-note 74 1772820 8820)
(make-note 59 1772820 8820)
(make-note 72 1781640 8820)
(make-note 57 1781640 8820)
(make-note 76 1790460 8820)
(make-note 55 1790460 8820)
(make-note 74 1799280 8820)
(make-note 54 1799280 8820)
(make-note 72 1808100 8820)
(make-note 57 1808100 8820)
(make-note 71 1816920 8820)
(make-note 56 1816920 8820)
(make-note 74 1825740 8820)
(make-note 59 1825740 8820)
(make-note 72 1834560 8820)
(make-note 57 1834560 8820)
(make-note 81 1843380 8820)
(make-note 60 1843380 8820)
(make-note 80 1852200 8820)
(make-note 59 1852200 8820)
(make-note 83 1861020 8820)
(make-note 62 1861020 8820)
(make-note 81 1869840 8820)
(make-note 60 1869840 8820)
(make-note 76 1878660 8820)
(make-note 64 1878660 8820)
(make-note 77 1887480 8820)
(make-note 62 1887480 8820)
(make-note 74 1896300 8820)
(make-note 65 1896300 8820)
(make-note 68 1905120 8820)
(make-note 64 1905120 17640)
(make-note 77 1913940 8820)
(make-note 76 1922760 8820)
(make-note 57 1922760 17640)
(make-note 74 1931580 8820)
(make-note 72 1940400 17640)
(make-note 64 1940400 17640)
(make-note 71 1958040 8820)
(make-note 52 1958040 17640)
(make-note 69 1966860 8820)
(make-note 69 1975680 8820)
(make-note 57 1975680 17640)
(make-note 81 1984500 8820)
(make-note 79 1993320 8820)
(make-note 45 1993320 17640)
(make-note 77 2002140 8820)
(make-note 76 2010960 8820)
(make-note 79 2019780 8820)
(make-note 77 2028600 8820)
(make-note 81 2037420 8820)
(make-note 79 2046240 77910)
(make-note 64 2055060 8820)
(make-note 62 2063880 8820)
(make-note 60 2072700 8820)
(make-note 59 2081520 8820)
(make-note 62 2090340 8820)
(make-note 61 2099160 8820)
(make-note 64 2107980 8820)
(make-note 62 2116800 77910)
(make-note 76 2125620 8820)
(make-note 77 2134440 8820)
(make-note 79 2143260 8820)
(make-note 81 2152080 8820)
(make-note 77 2160900 8820)
(make-note 79 2169720 8820)
(make-note 76 2178540 8820)
(make-note 77 2187360 79380)
(make-note 57 2196180 8820)
(make-note 59 2205000 8820)
(make-note 60 2213820 8820)
(make-note 62 2222640 8820)
(make-note 59 2231460 8820)
(make-note 60 2240280 8820)
(make-note 57 2249100 8820)
(make-note 59 2257920 77910)
(make-note 79 2266740 8820)
(make-note 77 2275560 8820)
(make-note 76 2284380 8820)
(make-note 74 2293200 8820)
(make-note 77 2302020 8820)
(make-note 76 2310840 8820)
(make-note 79 2319660 8820)
(make-note 77 2328480 77910)
(make-note 62 2337300 8820)
(make-note 60 2346120 8820)
(make-note 59 2354940 8820)
(make-note 57 2363760 8820)
(make-note 60 2372580 8820)
(make-note 59 2381400 8820)
(make-note 62 2390220 8820)
(make-note 60 2399040 77910)
(make-note 74 2407860 8820)
(make-note 76 2416680 8820)
(make-note 77 2425500 8820)
(make-note 79 2434320 8820)
(make-note 76 2443140 8820)
(make-note 77 2451960 8820)
(make-note 74 2460780 8820)
(make-note 76 2469600 77910)
(make-note 55 2478420 8820)
(make-note 57 2487240 8820)
(make-note 58 2496060 8820)
(make-note 60 2504880 8820)
(make-note 57 2513700 8820)
(make-note 58 2522520 8820)
(make-note 55 2531340 8820)
(make-note 57 2540160 17640)
(make-note 72 2548980 8820)
(make-note 74 2557800 8820)
(make-note 58 2557800 17640)
(make-note 76 2566620 8820)
(make-note 77 2575440 8820)
(make-note 57 2575440 17640)
(make-note 74 2584260 8820)
(make-note 76 2593080 8820)
(make-note 55 2593080 17640)
(make-note 72 2601900 8820)
(make-note 74 2610720 8820)
(make-note 53 2610720 17640)
(make-note 76 2619540 8820)
(make-note 77 2628360 8820)
(make-note 62 2628360 17640)
(make-note 79 2637180 8820)
(make-note 81 2646000 8820)
(make-note 60 2646000 17640)
(make-note 77 2654820 8820)
(make-note 79 2663640 8820)
(make-note 58 2663640 17640)
(make-note 76 2672460 8820)
(make-note 77 2681280 8820)
(make-note 57 2681280 17640)
(make-note 79 2690100 8820)
(make-note 81 2698920 8820)
(make-note 65 2698920 17640)
(make-note 83 2707740 8820)
(make-note 84 2716560 8820)
(make-note 64 2716560 17640)
(make-note 81 2725380 8820)
(make-note 83 2734200 8820)
(make-note 62 2734200 17640)
(make-note 79 2743020 8820)
(make-note 84 2751840 17640)
(make-note 64 2751840 8820)
(make-note 50 2760660 8820)
(make-note 79 2769480 17640)
(make-note 52 2769480 8820)
(make-note 53 2778300 8820)
(make-note 76 2787120 17640)
(make-note 55 2787120 8820)
(make-note 52 2795940 8820)
(make-note 74 2804760 8820)
(make-note 53 2804760 8820)
(make-note 72 2813580 8820)
(make-note 50 2813580 8820)
(make-note 72 2822400 8820)
(make-note 52 2822400 17640)
(make-note 70 2831220 8820)
(make-note 69 2840040 8820)
(make-note 48 2840040 17640)
(make-note 67 2848860 8820)
(make-note 65 2857680 8820)
(make-note 50 2857680 17640)
(make-note 69 2866500 8820)
(make-note 67 2875320 8820)
(make-note 52 2875320 17640)
(make-note 70 2884140 8820)
(make-note 69 2892960 8820)
(make-note 53 2892960 8820)
(make-note 71 2901780 8820)
(make-note 50 2901780 8820)
(make-note 72 2910600 8820)
(make-note 52 2910600 8820)
(make-note 64 2919420 8820)
(make-note 53 2919420 8820)
(make-note 62 2928240 8820)
(make-note 55 2928240 17640)
(make-note 72 2937060 8820)
(make-note 65 2945880 8820)
(make-note 43 2945880 17640)
(make-note 71 2954700 8820)
(make-note 36 2963520 141120)
(make-note 48 2964622 140018)
(make-note 64 2965725 138915)
(make-note 67 2966828 137812)
(make-note 72 2967930 136710))))

(define ps (make-pstream))

(define (both a b) b)

;; play the notes in a list
;; list-of-notes next-time -> pstream
(define (play-notes lon next-time)
  (cond [(empty? lon) ps]
        [else
         (both (play-note (car lon) next-time)
               (play-notes (cdr lon) (+ next-time (cdr (car lon)))))]))

(define (play-notes-now lon)
  (play-notes lon (+ (pstream-current-frame ps) 44100)))

;; play a single note
;; note number -> pstream
(define (play-note n when)
  (pstream-queue
   ps
   (clip (piano-tone (car n))
         0 (min (cdr n) (rs-frames (piano-tone (car n)))))
   when))

(define hashT (add-all (hash) bach-notes 3))

(define test-start (list (cons 60 8820) (cons 62 8820)))

(play-notes-now (predict-next-few hashT test-start 30 3))

markov.rkt

#lang racket/base
(require test-engine/racket-tests)
(require racket/list)
(require racket/string)

(provide add-all)
(provide predict-next-few)

;; Takes a hash table and a sequence of items and increments the 
;;     entry in the hash table associated with that sequence.
;; hash list-of-anythings -> hash
(define (add-stat hashT sequence)
  (cond [(null? (cdr sequence)) 
         (hash-set hashT (car sequence) (add1 (hash-ref hashT (car sequence) 0)))]
        [else
         (hash-set hashT (car sequence) (add-stat (hash-ref hashT (car sequence) (hash)) (cdr sequence)))]))


(check-expect (add-stat (add-stat (hash) '("a" "b" "c")) '("a" "b" "d"))
              '#hash(("a" . #hash(("b" . #hash(("c" . 1) ("d" . 1)))))))
(check-expect (add-stat (add-stat (hash) '("a" "b" "c")) '("a" "b" "c"))
              '#hash(("a" . #hash(("b" . #hash(("c" . 2)))))))



;;add-all calls add-stat a bunch of times to add every sequence of sequence (of length degree) to the pass hash table
;; hash list-of-anything number -> hash
(define (add-all hashT sequence degree)
  (cond [(<= degree (length sequence))
         (add-all (add-stat hashT (take sequence degree)) (cdr sequence) degree)]
        [else
         hashT]))






;;given a hash table and a list of preceding words, predicts the next word according to statistics noted in hashT
;; hash list-of-words -> anything
(define (predict-next hashT prev)
  (cond [(empty? prev)
         (pick-one hashT (random))]
        [else
         (predict-next (hash-ref hashT (car prev)) (cdr prev))]))

; function predict-next-few will call predict-next n times, each time taking into account the output from the last time
; takes a hashTable (output from add-all or add-stat), a list of previous elements, a number n 
; (how many outputs it will predict), and a number degree (how deep the hashtable is)
; hash list-of-words number number -> list-of-words
(define (predict-next-few hashT prev n degree)
  (cond [(< n 1)
         prev]
        [else
         (predict-next-few hashT 
                           (append prev (list (predict-next hashT (take-right prev (sub1 degree)))))
                           (sub1 n) 
                           degree)]))


;; given a hash table mapping keys to nats and a random number between 0 and 1,
;; produce one of the keys based on the distribution implied by the values in the
;; hash table.
;; (hashof any nat) real -> any
(define (pick-one table rand)
  (pick-one/list (hash-map table list) (* (sum-of-values table) rand)))

(check-expect (pick-one (hash "a" 5 "b" 2 "c" 3) 0.68) "b")
(check-expect (pick-one (hash "a" 5 "b" 2 "c" 3) 0.71) "c")



;; given a list mapping keys to numbers and a real number between
;; 0 and the sum of all the keys, return the appropriate key
;; (listof (list/c any nat)) nat real -> any
(define (pick-one/list assoc r)
  (cond [(empty? assoc)
         (raise-argument-error 'pick-one/list
                               "number <= the sum of the keys in the table"
                               1 assoc r)]
        [else
         (define weight-of-first (second (first assoc)))
         (cond [(<= r weight-of-first)
                (first (first assoc))]
               [else
                (pick-one/list (rest assoc) (- r weight-of-first))])]))


;; sum the values in the table
(define (sum-of-values ht)
  (for/sum ([v (in-hash-values ht)]) v))


(test)







;;write-all prints a list of words prettily (so it can be read like a story or posted to facebook)
;; list-of-words -> nothing
(define (write-all q)
  (cond [(null? q) q]
        [else
         (display (car q))
         (display " ")
         (write-all (cdr q))]))



(define letters (add-all (hash) (string-split "a b a c c a a d b a a d d a d a b c c a d a") 3))
;(predict-next letters '("a" "b"))
(predict-next-few letters (list "a" "b") 5 3)


(define little-girl (add-all (hash) (string-split "when I was a little girl I used to fly around the world fighting evil . me and my sidekick Bubbles both had super powers . her super power was to fly and mine was also to fly . together we fought the forces of evil . one time I was flying and I saw an evil thing . I told it to stop being evil . it said no . I got angry because it wouldn't stop being evil but Bubbles told me to not be angry . I am thankful that Bubbles was there to make me not be angry .") 3))
(write-all (predict-next-few little-girl (list "when" "I") 200 3))


;; this one runs into trouble 9 times out of 10 because not every word follows every word... not sure yet how to fix that...
(define bananas (add-all (hash) (string-split "one time I went to the grocery store and bought a banana . the banana was very small and I didn't enjoy it . the banana was so small that I was sad . one other time my grocery store came to me and I gave it a banana . the banana was big . the banana was so big that the grocery store was happy . the grocery store was so happy that it decided to give me a banana . when the grocery store decided to give me a banana I was happy . the banana was small . I was upset because the banana was small . I was upset with the grocery store because it decided to give me a small banana") 3))
(write-all (predict-next-few bananas (list "one" "time") 200 3))