-
Notifications
You must be signed in to change notification settings - Fork 0
/
bcw.scm
104 lines (104 loc) · 3.13 KB
/
bcw.scm
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
(use sndfile srfi-14 loops)
(define *pi_2 (* 2 (acos -1.0)))
(define alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 "))
(define alpha-codes '(".-"
"-..."
"-.-."
"-.."
" . "
"..-."
"--."
"...."
" .. "
".---"
"-.-"
".-.."
"--"
"-."
"---"
".--."
"--.-"
".-."
"..."
"-"
"..-"
"...-"
".--"
"-..-"
"-.--"
"--.."
"-----"
".----"
"..---"
"...--"
"....-"
"....."
"-...."
"--..."
"---.."
"----."
" "))
(define out-file "burstCW.wav")
(define s-per-sec 11025)
(define chans 1)
(define volume 1.0)
(define sp-count 26)
(define dot-count 6)
(define dash-count 20)
(define interchar-count 15)
(define cli (command-line-arguments))
(define msg (map char-upcase (string->list (cadr cli))))
(define freq (if (>= (length cli) 3) (string->number (caddr cli)) #f))
(when (not freq)
(set! freq 3600))
(print "msg:" msg)
(define fr-count 0)
(define (ch l k #!optional (i 0))
(if (null? l)
#f
(if (eq? (car l) k)
i
(ch (cdr l) k (add1 i)))))
(define (get-char-wav-seq wr h x)
(let ((y '()))
(when (not (null? x))
(set! y (car x)))
(cond
((eq? y #\space)
(do-times i sp-count
(set! fr-count (add1 fr-count))
(wr h (list->f32vector '(0.0)))))
((or (eq? y #\.) (eq? y #\-))
(let ((d (if (eq? y #\.) dot-count dash-count)))
(do-times i d
(set! fr-count (add1 fr-count))
(wr h (list->f32vector
`(,(* volume (sin (/ (* *pi_2
freq
fr-count)
s-per-sec))))))))
(do-times i interchar-count
(wr h (list->f32vector '(0.0)))))))
(when (>= (length x) 1)
(get-char-wav-seq wr h (cdr x))))
(define (make-wav wr h m)
(and-let* ((x (if (null? m) (ch alpha #\space) (ch alpha (car m)))))
(get-char-wav-seq
wr
h
(string->list (list-ref alpha-codes x)))
(do-times i sp-count
(wr h (list->f32vector '(0.0))))
(when (not (null? m))
(make-wav wr h (if (null? m) m (cdr m))))))
(with-sound-to-file
out-file
'(wav pcm-16 file)
s-per-sec
chans
(lambda (h)
(when (not (make-wav write-items/f32
h
msg))
(print "undefined character found, valid characters are a-z,A-Z,0-9"))))
(exit)