1#!/usr/bin/perl
2
3use warnings;
4use strict;
5
6sub write_byte {
7
8  my( $b ) = @_;
9
10  printf "%c", $b;
11}
12
13sub write_word {
14
15  my( $w ) = @_;
16
17  write_byte( $w % 0x100 );
18  write_byte( $w / 0x100 );
19}
20
21sub write_three {
22
23  my( $three ) = @_;
24
25  write_byte( $three % 0x100 );
26  write_word( $three / 0x100 );
27
28}
29
30sub write_dword {
31
32  my( $dw ) = @_;
33
34  write_word( $dw % 0x10000 );
35  write_word( $dw / 0x10000 );
36}
37
38sub write_header {
39
40  print "ZXTape!\x1a";		# Signature
41  write_byte(  1 );		# Major version number
42  write_byte( 20 );		# Minor version number
43
44}
45
46sub write_standard_speed_data_block {
47
48  my( $data, $pause ) = @_;
49
50  write_byte( 0x10 );
51  write_word( $pause );
52  write_word( length $data );
53  print $data;
54
55}
56
57sub write_turbo_speed_data_block {
58
59  my( $pilot_length, $pilot_count, $sync1_length, $sync2_length,
60      $zero_length, $one_length, $data, $bits_in_last_byte, $pause ) = @_;
61
62  write_byte( 0x11 );
63  write_word( $pilot_length );
64  write_word( $sync1_length );
65  write_word( $sync2_length );
66  write_word( $zero_length );
67  write_word( $one_length );
68  write_word( $pilot_count );
69  write_byte( $bits_in_last_byte );
70  write_word( $pause );
71  write_three( length $data );
72  print $data;
73
74}
75
76sub write_pure_tone_block {
77
78  my( $length, $count ) = @_;
79
80  write_byte( 0x12 );
81  write_word( $length );
82  write_word( $count );
83
84}
85
86sub write_pulse_sequence_block {
87
88  my( @data ) = @_;
89
90  write_byte( 0x13 );
91  write_byte( scalar @data );
92  write_word( $_ ) foreach @data;
93
94}
95
96sub write_pure_data_block {
97
98  my( $zero_length, $one_length, $data, $bits_in_last_byte, $pause ) = @_;
99
100  write_byte( 0x14 );
101  write_word( $zero_length );
102  write_word( $one_length );
103  write_byte( $bits_in_last_byte );
104  write_word( $pause );
105  write_three( length $data );
106  print $data;
107
108}
109
110sub write_pause_block {
111
112  my( $pause ) = @_;
113
114  write_byte( 0x20 );
115  write_word( $pause );
116
117}
118
119sub write_group_start_block {
120
121  my( $name ) = @_;
122
123  write_byte( 0x21 );
124  write_byte( length $name );
125  print $name;
126
127}
128
129sub write_group_end_block {
130
131  my( $name ) = @_;
132
133  write_byte( 0x22 );
134
135}
136
137sub write_jump_block {
138
139  my( $offset ) = @_;
140
141  write_byte( 0x23 );
142  write_word( $offset );
143
144}
145
146sub write_loop_start_block {
147
148  my( $iterations ) = @_;
149
150  write_byte( 0x24 );
151  write_word( $iterations );
152
153}
154
155sub write_loop_end_block {
156
157  write_byte( 0x25 );
158
159}
160
161sub write_stop_tape_if_in_48k_mode_block {
162
163  write_byte( 0x2a );
164  write_dword( 0 );
165
166}
167
168sub write_text_description_block {
169
170  my( $text ) = @_;
171
172  write_byte( 0x30 );
173  write_byte( length $text );
174  print $text;
175
176}
177
178sub write_message_block {
179
180  my( $text, $time ) = @_;
181
182  write_byte( 0x31 );
183  write_byte( $time );
184  write_byte( length $text );
185  print $text;
186
187}
188
189sub write_archive_info_block {
190
191  my( @strings ) = @_;
192
193  write_byte( 0x32 );
194
195  my $data;
196
197  foreach my $string ( @strings ) {
198    $data .= chr( $string->{id} );
199    $data .= chr( length $string->{text} );
200    $data .= $string->{text};
201  }
202
203  write_word( length $data );
204  write_byte( scalar @strings );
205  print $data;
206
207}
208
209sub write_hardware_type_block {
210
211  my( @info ) = @_;
212
213  write_byte( 0x33 );
214  write_byte( scalar @info );
215
216  foreach my $info ( @info ) {
217    write_byte( $info->{type} );
218    write_byte( $info->{id} );
219    write_byte( $info->{used} );
220  }
221}
222
223sub write_custom_info_block {
224
225  my( $id, $data ) = @_;
226
227  write_byte( 0x35 );
228
229  if( length $id < 16 ) {
230    $id .= ' ' x ( 16 - length $id );
231  } elsif( length $id > 16 ) {
232    $id = substr( $id, 0, 16 );
233  }
234  print $id;
235  write_dword( length $data );
236  print $data;
237
238}
239
240write_header();
241
242write_standard_speed_data_block( "\xaa", 2345 );
243
244write_turbo_speed_data_block( 1000, 5, 123, 456, 789, 400, "\x00\xff\x55\xa0",
245			      4, 987 );
246
247write_pure_tone_block( 535, 666 );
248
249write_pulse_sequence_block( 772, 297, 692 );
250
251write_pure_data_block( 552, 1639, "\xff\x00\xfc", 6, 554 );
252
253write_pause_block( 618 );
254
255write_group_start_block( "Group Start" );
256
257write_group_end_block();
258
259write_jump_block( 2 );
260
261write_pure_tone_block( 303, 678 );
262
263write_loop_start_block( 3 );
264
265write_pure_tone_block( 837, 185 );
266
267write_loop_end_block();
268
269write_stop_tape_if_in_48k_mode_block();
270
271write_text_description_block( "Comment here" );
272
273write_message_block( "A message", 1 );
274
275write_archive_info_block( { id => 0x00, text => "Full title" },
276			  { id => 0x03, text => "Year"       } );
277
278write_hardware_type_block( { type => 0x00, id => 0x01, used => 0x00 },
279			   { type => 0x02, id => 0x02, used => 0x03 } );
280
281write_custom_info_block( "Complete TZX", "Arbitrary custom data" );
282
283write_pure_tone_block( 820, 941 );
284