-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathUSPEAKER.PAS
145 lines (122 loc) · 2.8 KB
/
USPEAKER.PAS
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
{
uspeaker Unit
2022 LRT
}
unit
uspeaker;
interface
uses
consts, utils, uexc, uclasses, types, locale, uobject, xcrt;
type
PTone = ^TTone;
TTone = packed record
samples: pword;
sampleCount: byte;
reverse: boolean;
end;
ETone = (
EToneWah,
EToneDing
);
PSpeaker = ^TSpeaker;
TSpeaker = object (TObject)
public
constructor init;
destructor done; virtual;
procedure setTone(tone: ETone);
procedure sound(hz: word);
procedure silence;
function getClassName: string; virtual;
function getClassId: word; virtual;
private
_tone: PTone;
procedure play(hz: word);
end;
implementation
const
C_SAMPLE_DURATION = 3;
C_TONE_WAH_SAMPLE_COUNT = 16;
C_TONE_WAH_SAMPLES: array[0..C_TONE_WAH_SAMPLE_COUNT-1] of word = (
500, 500, 500, 500, 500, 500, 500, 500,
1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000
);
C_TONE_WAH: TTone = (
samples: @C_TONE_WAH_SAMPLES;
sampleCount: C_TONE_WAH_SAMPLE_COUNT;
reverse: true
);
C_TONE_DING_SAMPLE_COUNT = 16;
C_TONE_DING_SAMPLES: array[0..C_TONE_DING_SAMPLE_COUNT-1] of word = (
2500, 1500, 1100, 600, 400, 300, 200, 250, 100, 70, 50, 40, 20, 15, 10, 5
);
C_TONE_DING: TTone = (
samples: @C_TONE_DING_SAMPLES;
sampleCount: C_TONE_DING_SAMPLE_COUNT;
reverse: false
);
C_TONES : array[ETone] of PTone = (
@C_TONE_WAH,
@C_TONE_DING
);
{ TSpeaker public }
constructor TSpeaker.init;
begin
inherited init;
_tone := C_TONES[ETone(0)];
end;
destructor TSpeaker.done;
begin
inherited done;
end;
procedure TSpeaker.setTone(tone: ETone);
begin
_tone := C_TONES[tone];
end;
procedure TSpeaker.sound(hz: word);
begin
play(hz);
end;
procedure TSpeaker.silence;
begin
nosound;
end;
function TSpeaker.getClassName: string;
begin
getClassName := 'TSpeaker';
end;
function TSpeaker.getClassId: word;
begin
getClassId := C_CLASS_ID_Speaker;
end;
{ TSpeaker private }
procedure TSpeaker.play(hz: word);
var
i: byte;
p: pword;
curr, prev: word;
begin
curr := $FFFF;
with _tone^ do
begin
p := samples;
for i:=0 to sampleCount-1 do
begin
prev := curr;
curr := hz + p^;
if prev <> curr then xcrt.sound(curr);
delay(C_SAMPLE_DURATION);
inc(p);
end;
if reverse then
for i:=sampleCount-1 downto 0 do
begin
if prev <> curr then xcrt.sound(curr);
delay(C_SAMPLE_DURATION);
dec(p);
prev := curr;
curr := hz + p^;
end;
end;
end;
{ Other }
end.