about summary refs log tree commit diff stats
path: root/js/games/nluqo.github.io/~bh/61a-pages/Lib/pronounce.scm
blob: 638e160508df823ea3b0c1289644cee1f2dffa9e (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
; How to pronounce cxr-family function names

(define (say name)
  (accent (pronounce name)))

; PRONOUNCE takes a cxr-family word as argument and returns a sentence
; of syllables.

(define (pronounce name)
  (cond ((eq? name 'car) '(car))
	((eq? name 'caar) '(cuh are))
	((empty? name) '())
	((eq? (first-two name) 'ca) (se 'caa (pronounce (bf-two name))))
	((eq? (first name) 'c) (se 'cuh (pronounce (bf name))))
	((eq? (last-three name) 'dar) (se (pronounce (bl-three name)) 'dar))
	((eq? (last-two name) 'ar) (se (pronounce (bl-two name)) 'are))
	((eq? (last-two name) 'dr) (se (pronounce (bl-two name)) 'der))
	((eq? (first-two name) 'da) (se 'daa (pronounce (bf-two name))))
	((eq? (first name) 'a) (se 'aa (pronounce (bf name))))
	(else (se 'de (pronounce (bf name))))))

; ACCENT takes a sentence of syllables (as returned by PRONOUNCE) and inserts
; an exclamation point at the emphasized syllable.  I'm less sure that these
; rules are universally agreed to than for PRONOUNCE.

; In particular, all my life I've said "CUH de der" for cddr, but apparently
; to be consistent I should be saying "cuh DE der."  I think I have heard people
; say it that way, though, so I'm reluctant to special-case it like the first
; syllable of caar in PRONOUNCE.

(define (accent syls)
  (define (help prev rest)
    (if (null? rest)
	(se (word prev '!))
	(let ((winover (assoc prev '((caa . (daa dar de der))
				     (cuh . (der))
				     (aa  . (dar de der))
				     (daa . (aa are daa dar de der))
				     (de  . (de der))))))
	  (if (member? (car rest) (cdr winover))
	      (cons (word prev '!) rest)
	      (cons prev (help (car rest) (cdr rest)))))))
  (if (null? (cdr syls))
      syls
      (help (car syls) (cdr syls))))

; Utility functions to get a table of pronunciations of all names up to length n

(define (table n)
  (for-each (lambda (w) (print (list w (say w)))) (cr n)))

(define (cr n)
  (if (= n 0)
      '()
      (append (cr (- n 1))
	      (map (lambda (w) (word 'c w 'r)) (cross n)))))

(define (cross n)
  (if (= n 0)
      '("")
      (let ((small (cross (- n 1))))
	(append (map (lambda (w) (word w 'a)) small)
		(map (lambda (w) (word w 'd)) small)))))

; Helper functions are obvious except to note that they test for too-short
; arguments so that we can make more specific tests first in PRONOUNCE above.
; ("More specific" means that we test for long substrings before short ones.)

(define (first-two wd)
  (if (< (count wd) 2)
      wd
      (word (first wd) (first (bf wd)))))

(define (bf-two wd)
  (if (< (count wd) 2)
      ""
      (bf (bf wd))))

(define (last-two wd)
  (if (< (count wd) 2)
      wd
      (word (last (bl wd)) (last wd))))

(define (bl-two wd)
  (if (< (count wd) 2)
      ""
      (bl (bl wd))))

(define (last-three wd)
  (if (< (count wd) 3)
      wd
      (word (last (bl (bl wd))) (last (bl wd)) (last wd))))

(define (bl-three wd)
  (if (< (count wd) 3)
      ""
      (bl (bl (bl wd)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Results:

; > (table 5)
; (car (car))
; (cdr (cuh! der))
; (caar (cuh are!))
; (cdar (cuh dar!))
; (cadr (caa! der))
; (cddr (cuh de! der))
; (caaar (caa aa are!))
; (cdaar (cuh daa! are))
; (cadar (caa! dar))
; (cddar (cuh de dar!))
; (caadr (caa aa! der))
; (cdadr (cuh daa! der))
; (caddr (caa! de der))
; (cdddr (cuh de! de der))
; (caaaar (caa aa aa are!))
; (cdaaar (cuh daa! aa are))
; (cadaar (caa! daa are))
; (cddaar (cuh de daa! are))
; (caadar (caa aa! dar))
; (cdadar (cuh daa! dar))
; (caddar (caa! de dar))
; (cdddar (cuh de! de dar))
; (caaadr (caa aa aa! der))
; (cdaadr (cuh daa! aa der))
; (cadadr (caa! daa der))
; (cddadr (cuh de daa! der))
; (caaddr (caa aa! de der))
; (cdaddr (cuh daa! de der))
; (cadddr (caa! de de der))
; (cddddr (cuh de! de de der))
; (caaaaar (caa aa aa aa are!))
; (cdaaaar (cuh daa! aa aa are))
; (cadaaar (caa! daa aa are))
; (cddaaar (cuh de daa! aa are))
; (caadaar (caa aa daa! are))
; (cdadaar (cuh daa! daa are))
; (caddaar (caa! de daa are))
; (cdddaar (cuh de! de daa are))
; (caaadar (caa aa aa! dar))
; (cdaadar (cuh daa! aa dar))
; (cadadar (caa! daa dar))
; (cddadar (cuh de daa! dar))
; (caaddar (caa aa! de dar))
; (cdaddar (cuh daa! de dar))
; (cadddar (caa! de de dar))
; (cddddar (cuh de! de de dar))
; (caaaadr (caa aa aa aa! der))
; (cdaaadr (cuh daa! aa aa der))
; (cadaadr (caa! daa aa der))
; (cddaadr (cuh de daa! aa der))
; (caadadr (caa aa daa! der))
; (cdadadr (cuh daa! daa der))
; (caddadr (caa! de daa der))
; (cdddadr (cuh de! de daa der))
; (caaaddr (caa aa aa! de der))
; (cdaaddr (cuh daa! aa de der))
; (cadaddr (caa! daa de der))
; (cddaddr (cuh de daa! de der))
; (caadddr (caa aa! de de der))
; (cdadddr (cuh daa! de de der))
; (caddddr (caa! de de de der))
; (cdddddr (cuh de! de de de der))