#!/usr/bin/perl -wT # bin2cas.pl - convert binary data to CAS or WAV with optional autorun # Copyright 2017-2022 Ciaran Anscomb # License: GNU GPL version 3 or later . # This is free software: you are free to change and redistribute it. # There is NO WARRANTY, to the extent permitted by law. # # Special exception: Code included in output (such as "dunzip" or "unzx0") is # not considered to be part of this program, so the GPL doesn't apply to the # results. # See the output of "bin2cas.pl --help" for detailed usage information, with # examples. # Pre-v2.0: really rubbish # Pre-v3.0: getting better, but still limited # v3.0: complete overhaul # supports multiple parts # builds reasonably arbitrary autorun loader # update VDG & SAM configs during loading # manual cursor flasher for when video offset changed # v3.0a: tweak default samplerate to 12kHz if fast mode used # slightly increase speed in fast mode # v3.1: default timing uses varying pulse widths to account for ROM delays # --timing option selects between "rom" and "simple" timing # fast cycle timing better at 9600Hz, so dropped default back # slightly faster WAV creation by caching runs of samples # v3.2: don't redirect STDOUT # new option --lds inserts stack adjustment code into autorun # license foo, --version # v3.3: actually drop default to 9600Hz # dzip using temp files under windows # v3.4: add --no-delay, --block-size, --gapped, --pause, --wav-bits # --cas, --wav deprecated, use --mode or rely on file extension # fix --no-eof # tweak waveform output # v3.5: add --poke # v3.6: use Getopt::Long and Pod::Usage # remove deprecated --dunzip # accept $ as well as 0x to indicate hex argument # v3.7: add --vxor # v3.8: dzipped data needs *3* bytes clear of overlap! # v3.9: actually, dzip offset depends on number of runs at end # v3.10: include load_part, dunzip pointers at known address # v3.11: add --omit # v3.12: add --cue # v3.13: add --memset # v3.14: allow --timing double # new block formats: namefile, data, eof # add --zx0 to support ZX0 compression using salvador use strict; require v5.10; use Getopt::Long; use Pod::Usage; use File::Temp qw/tempfile tempdir/; use Math::Trig; require bytes; use constant VERSION => "3.14"; use constant { TYPE_BASIC => 0, TYPE_DATA => 1, TYPE_BINARY => 2, }; use constant { DDOS_TYPE_BASIC => 1, DDOS_TYPE_BINARY => 2, }; use constant { ENCODING_BINARY => 0, ENCODING_ASCII => 0xff, }; use constant { GAP_FALSE => 0, GAP_TRUE => 0xff, }; use constant { BLOCK_NAMEFILE => 0, BLOCK_DATA => 1, BLOCK_EOF => 0xff, }; use constant { INPUT_RAW => 0, INPUT_DRAGONDOS => 1, INPUT_COCO => 2, }; use constant { CUE_TIMING => 0xf0, CUE_SILENCE => 0x00, CUE_DATA => 0x0d, CUE_COMMENT => 0x22, }; use constant { ZX0_COPY_LITERALS => 0, ZX0_COPY_FROM_LAST_OFFSET => 1, ZX0_COPY_FROM_NEW_OFFSET => 2, }; use constant DEFAULT_SAMPLE_RATE => 9600; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Sekr1t options support writing specific games as accurately as possible: # Tube Way Army: # Loader: --name "TWA" --load 0 --exec 0 --gapped --timing rom # Delay: --pause --pause # Game: --no-filename --block-size 128 --block-fmt twa --timing twa # Superkid: # Loader: --name "SUPERKID" --load 0x012c --exec 0x4000 --timing rom # Block0: --no-filename --no-eof --timing sk.b0 # Screen0: --no-filename --no-delay --no-eof --timing sk.s0 # --block-fmt bare --block-size 0 # Screen1: --no-filename --no-delay --no-eof --timing sk.s1 # --block-fmt bare --block-size 0 # Game: --no-filename --no-delay --no-eof --timing sk.g # --block-fmt bare --block-size 0 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Map DragonDOS filetypes to tape filetypes. my %ddos_to_tape_type = ( DDOS_TYPE_BASIC => TYPE_BASIC, DDOS_TYPE_BINARY => TYPE_BINARY, ); # Wave data. my @wav_header = ( 0x52, 0x49, 0x46, 0x46, 0x00, 0x00, 0x00, 0x00, 0x57, 0x41, 0x56, 0x45, 0x66, 0x6d, 0x74, 0x20, 0x10, 0x00, 0x00, 0x00, 0x01, 0x00, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x00, 0x08, 0x00, 0x64, 0x61, 0x74, 0x61, 0x00, 0x00, 0x00, 0x00 ); # Timings # 'cycles' is the nominal number of CPU cycles (SAM / 16) in the waveform for # each bit (0, 1), the rest are pulse specs. # Pulse spec is three pairs of pulse delays (first pulse, second pulse): # - first bit of first byte # - remaining bits in each byte # - first bit of subsequent bytes # 'leader' is pulse spec while writing leader bytes and the sync byte # 'first' is pulse spec for the first byte in a block # 'rest' is pulse spec for remaining bytes in a block (until next leader) # The "rom" spec is intended to be the "best fit" for the Dragon ROM - # that is, the ROM will count an "ideal" pulse width for each bit. This should # improve reliability. my %timing_simple = ( 'cycles' => [ 813, 435 ], 'leader0' => [ 0, 0, 0, 0 ], 'leader' => [ 0, 0, 0, 0 ], 'type' => [ 46, 0, 0, 0 ], 'size' => [ 46, 0, 0, 0 ], 'data0' => [ 46, 0, 0, 0 ], 'data' => [ 46, 0, 0, 0 ], # 818.75, 440.75 -> 629.75 'sum' => [ 46, 0, 0, 0 ], ); my %timing_rom = ( 'cycles' => [ 26*28, 13*28 ], 'leader0' => [ 205, 5, 68, 5 ], 'leader' => [ 68, 5, 68, 5 ], 'type' => [ 81, 5, 67, 5 ], 'size' => [ 120, 5, 67, 5 ], 'data0' => [ 120, 5, 67, 5 ], 'data' => [ 120, 5, 67, 5 ], # 806.625, 442.625 -> 625.625 'sum' => [ 120, 5, 67, 5 ], ); my %timing_double = ( 'cycles' => [ 13*28, 6.5*28 ], 'leader0' => [ 103, 3, 34, 3 ], 'leader' => [ 34, 3, 34, 3 ], 'type' => [ 41, 3, 34, 4 ], 'size' => [ 60,3, 34, 4 ], 'data0' => [ 60,3, 34, 4 ], 'data' => [ 60,3, 34, 4 ], 'sum' => [ 60,3, 34, 4 ], ); my %timing_fast = ( 'cycles' => [ 18*28, 7*28 ], 'leader0' => [ 205, 5, 68, 5 ], 'leader' => [ 68, 5, 68, 5 ], 'type' => [ 81, 5, 67, 5 ], 'size' => [ 120, 5, 67, 5 ], 'data0' => [ 120, 5, 67, 5 ], 'data' => [ 120, 5, 67, 5 ], # 582.625, 274.625 -> 428.125 'sum' => [ 120, 5, 67, 5 ], ); my %timing_twa = ( 'cycles' => [ 26*28, 13*28 ], 'leader0' => [ 114, 5, 54, 5 ], 'leader' => [ 54, 5, 54, 5 ], 'size' => [ 67, 5, 58, 5 ], 'type' => [ 82, 5, 58, 5 ], 'data0' => [ 101, 5, 58, 5 ], 'data' => [ 106, 5, 58, 5 ], # 797.0, 433.0 -> 615.0 'sum' => [ 106, 5, 58, 5 ], ); my %timing_sk_b0 = ( 'cycles' => [ 25*28, 11*28 ], 'leader0' => [ 205, 5, 68, 5 ], 'leader' => [ 68, 5, 68, 5 ], 'type' => [ 81, 5, 67, 5 ], 'size' => [ 120, 5, 67, 5 ], 'data0' => [ 120, 5, 67, 5 ], 'data' => [ 120, 5, 67, 5 ], 'sum' => [ 120, 5, 67, 5 ], ); my %timing_sk_s0 = ( 'cycles' => [ 25*28, 11*28 ], 'data0' => [ 89, 5, 67, 5 ], 'data' => [ 112, 5, 67, 5 ], ); my %timing_sk_s1 = ( 'cycles' => [ 25*28, 11*28 ], 'data0' => [ 115, 5, 67, 5 ], 'data' => [ 112, 5, 67, 5 ], ); my %timing_sk_g = ( 'cycles' => [ 25*28, 11*28 ], 'leader' => [ 132, 5, 67, 5 ], 'data0' => [ 125, 5, 67, 5 ], 'data' => [ 132, 5, 67, 5 ], 'adj_period' => 8, 'adj' => 6, ); my %timing_by_name = ( 'simple' => \%timing_simple, 'rom' => \%timing_rom, 'fast' => \%timing_fast, 'double' => \%timing_double, 'twa' => \%timing_twa, 'sk.b0' => \%timing_sk_b0, 'sk.s0' => \%timing_sk_s0, 'sk.s1' => \%timing_sk_s1, 'sk.g' => \%timing_sk_g, ); # Block format strings my %fmt_strings = ( 'bare' => 'd', 'twa' => 'iSTdCo', 'normal' => 'itsdco', 'namefile' => 'insdco', 'data' => 'ibsdco', 'eof' => 'iesdco', ); # Autorun headers can include optional parts, concatenated and subject to # linking. my @code_load_0 = ( "load_part", 0x9f, 0x7e, # stx <$7e 0xad, 0x9f, 0xa0, 0x04, # jsr [CSRDON] "l0", ); my @code_load_flash = ( 0xb6, ">flash_addr", # lda >flash_addr 0x88, 0x40, # eora #$40 # flash code starts off disabled (first load will still be in text mode) "mod_flash", 0x8c, ">flash_addr", # cmpx >flash_addr ); my @code_load_1 = ( 0xad, 0x9f, 0xa0, 0x06, # jsr [BLKIN] 0x26, "\&$ff21 0x84, 0xf7, # anda #$f7 0xb7, 0xff, 0x21, # sta >$ff21 "do_rts", 0x39, # rts "do_io_error", 0x0f, 0x71, # clr <$71 0x6e, 0x9f, 0xff, 0xfe, # jmp [$fffe] ); my @code_disable_flasher = ( 0x86, 0x8c, # lda #$8c ; cmpx 0xb7, ">mod_flash", # sta mod_flash ); my @code_enable_flasher = ( 0x86, 0xb7, # lda #$8c ; sta 0xb7, ">mod_flash", # sta mod_flash ); my @code_test_arch = ( 0xb6, 0xa0, 0x00, # lda $a000 0x84, 0x20, # anda #$20 0x97, 0x10, # sta <$10 ); my @code_fast = ( 0xcc, ">fast_pw", # ldd #fast_pw 0x0d, 0x10, # tst <$10 0x26, "\& \$out_filename, "mode|m=s" => sub { shift; my $v = lc(shift @ARGV); $wav_out = ($v eq 'wav'); }, "cas" => sub { $wav_out = 0; }, "wav-out|wav" => sub { $wav_out = 1; }, "wav-rate|r=s" => sub { shift; $sample_rate = eval_int(shift) }, "wav-bits|b=s" => sub { shift; $bits_per_sample = eval_int(shift) }, # Global options: "autorun|A!" => \$autorun, "leader=s" => sub { shift; $leader = eval_int(shift) }, "cue!" => \$cue, # Per-file options: "B" => sub { $input_mode = INPUT_RAW; }, "D" => sub { $input_mode = INPUT_DRAGONDOS; }, "C" => sub { $input_mode = INPUT_COCO; }, "name|n=s" => sub { shift; $want_name = shift; $autorun_name = $want_name; }, "load|l=s" => sub { shift; $want_load = eval_int(shift) }, "exec|e=s" => sub { shift; $want_exec = eval_int(shift); $autorun_exec = $want_exec; }, "zload=s" => sub { shift; $want_zload = eval_int(shift) }, "filename!" => \$want_fnblock, "delay!" => \$want_delay, "block-size=s" => sub { shift; $block_size = eval_int(shift) }, "block-fmt=s" => \$block_fmt, "eof!" => \$want_eof, "gapped!" => \$want_gapped, "timing|T=s" => sub { shift; $want_timing = shift; $any_fast = 1 if ($want_timing eq 'fast'); }, "fast" => sub { $want_timing = 'fast'; $any_fast = 1; }, "no-fast" => sub { undef $want_timing; }, "omit!" => \$want_omit, "no-flasher|noflasher" => sub { $want_flasher = 0; }, "flasher" => sub { $want_flasher = 1; $any_flasher = 1; }, "vxor|x=s" => sub { shift; $want_vxor = shift; }, "no-vxor|novxor" => sub { $want_vxor = 0; }, "i=s" => sub { shift; push @files, input_file(shift); }, # Per-file persistent options: "dzip|z" => sub { $want_dzip = 1; $any_dzip = 1; $want_zx0 = 0; }, "zx0" => sub { $want_zx0 = 1; $any_zx0 = 1; $want_dzip = 0; }, "no-dzip|nodzip" => sub { $want_dzip = 0; }, "no-zx0|nozx0" => sub { $want_zx0 = 0; }, "reverse-dzip" => sub { $reverse_dzip = 1; }, "eof-data|E!" => \$want_eof_data, # Inter-file options: "lds=s" => sub { shift; push @files, { 'code' => "lds", 'value' => eval_int(shift) }; }, "pause" => sub { push @files, { 'code' => "pause", 'value' => 0 }; }, "sam-f=s" => sub { shift; push @files, { 'code' => "set_sam_f", 'value' => eval_int(shift) }; }, "sam-v=s" => sub { shift; my $v = eval_int(shift); push @files, { 'code' => "set_sam_v", 'value' => $v }; }, "vdg=s" => sub { shift; push @files, { 'code' => "set_vdg", 'value' => eval_int(shift) }; }, "poke=s" => sub { shift; my $v = shift; push @files, { 'code' => "poke", 'value' => $v }; }, "memset=s" => sub { shift; my $v = shift; push @files, { 'code' => "memset", 'value' => $v }; $any_memset = 1; }, # Other options: "version" => \&version_text, "help|?" => sub { pod2usage(-verbose => 2); }, # pass_through option means anything else hits this, so die if # it looks like an option we don't handle, else treat it as an # input file: "<>" => sub { my $file = shift; die "Unrecognised option: $file\n" if ($file =~ /^-/); push @files, input_file($file); }, ) or exit(2); die "invalid bits per sample (choose 8 or 16)\n" if ($bits_per_sample != 8 && $bits_per_sample != 16); if (defined $out_filename && $out_filename =~ /(.*)/) { $out_filename = $1; # de-taint } else { die "No output filename specified\n"; } if (@ARGV) { shift @ARGV; # discard -- while (@ARGV) { push @files, input_file(shift @ARGV); } } # Prepare output stream. open($out_fd, ">", $out_filename) or die $!; binmode $out_fd; if ($out_filename =~ /\.cas$/i) { $wav_out //= 0; } elsif ($out_filename =~ /\.wav$/i) { $wav_out //= 1; } $sample_rate //= DEFAULT_SAMPLE_RATE; my $sam_rate = 14318180; my $bytes_per_sample = $bits_per_sample >> 3; my $cue_data = ""; my $cue_cas_data_start = 0; my $cue_bit0_length = -1; my $cue_bit1_length = -1; # WAV header? if ($wav_out) { # No CUE for WAV $cue = 0; # NumChannels $wav_header[22] = $num_channels; $wav_header[23] = ($num_channels >> 8) & 0xff; # SampleRate $wav_header[24] = $sample_rate & 0xff; $wav_header[25] = ($sample_rate >> 8) & 0xff; $wav_header[26] = ($sample_rate >> 16) & 0xff; $wav_header[27] = ($sample_rate >> 24) & 0xff; # ByteRate my $byte_rate = $sample_rate * $num_channels * $bytes_per_sample; $wav_header[28] = $byte_rate & 0xff; $wav_header[29] = ($byte_rate >> 8) & 0xff; $wav_header[30] = ($byte_rate >> 16) & 0xff; $wav_header[31] = ($byte_rate >> 24) & 0xff; # BlockAlign my $block_align = ($num_channels * $bits_per_sample) / 8; $wav_header[32] = $block_align & 0xff; $wav_header[33] = ($block_align >> 8) & 0xff; # BitsPerSample $wav_header[34] = $bits_per_sample & 0xff; $wav_header[35] = ($bits_per_sample >> 8) & 0xff; print $out_fd pack("C*", @wav_header); } # Write file(s). write_autorun(\@files) if ($autorun); write_all_files(\@files); write_autorun_post(\@files) if ($autorun); # Close output. if ($wav_out) { # rewrite Subchunk2Size $sample_count *= $bytes_per_sample; seek($out_fd, 40, 0); print $out_fd pack("C", $sample_count & 0xff); print $out_fd pack("C", ($sample_count >> 8) & 0xff); print $out_fd pack("C", ($sample_count >> 16) & 0xff); print $out_fd pack("C", ($sample_count >> 24) & 0xff); # rewrite ChunkSize $sample_count += 36; seek($out_fd, 4, 0); print $out_fd pack("C", $sample_count & 0xff); print $out_fd pack("C", ($sample_count >> 8) & 0xff); print $out_fd pack("C", ($sample_count >> 16) & 0xff); print $out_fd pack("C", ($sample_count >> 24) & 0xff); } if ($cue) { cue_finish_cas_data(); my $cue_start = tell($out_fd); print $out_fd "[CUE"; print $out_fd $cue_data; print $out_fd pack("N", $cue_start); print $out_fd "CUE]"; } exit 0; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub reset_default_options { $input_mode = INPUT_RAW; undef $want_name; undef $want_load; undef $want_exec; undef $want_zload; undef $want_fnblock; $want_delay = 1; $block_size = 255; $block_fmt = 'normal'; $want_eof = 1; $want_gapped = 0; undef $want_timing; $want_flasher = 0; $want_vxor = 0; } # Read a file, applying current default options, reset default options. sub input_file { my ($filename,$file) = @_; $file //= {}; # defaults $file->{'fnblock'} //= $want_fnblock; $file->{'delay'} //= $want_delay; $file->{'block_size'} //= $block_size; $file->{'block_fmt'} //= $block_fmt; $file->{'eof'} //= $want_eof; $file->{'eof_data'} //= $want_eof_data; $file->{'gapped'} //= $want_gapped; $file->{'timing'} //= $want_timing; $file->{'flasher'} //= $want_flasher; $file->{'omit'} //= $want_omit; # read in appropriate mode $file = do { if ($input_mode == INPUT_DRAGONDOS) { read_dragondos($filename, $file); } elsif ($input_mode == INPUT_COCO) { read_coco($filename, $file); } else { read_raw($filename, $file); } }; # overrides $file->{'name'} = $want_name if (defined $want_name); $file->{'load'} = $want_load if (defined $want_load); $file->{'exec'} = $want_exec if (defined $want_exec); $file->{'zload'} = $want_zload if (defined $want_zload); die "No data\n" unless exists $file->{'segments'}; # XXX only deal with single-segment binaries for now coalesce_file($file); vxor_file($file) if ($want_vxor); dzip_file($file) if ($want_dzip); zx0_file($file) if ($want_zx0); reset_default_options(); return $file; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # File readers sub open_file { my ($filename,$file) = @_; $file //= {}; open(my $in, "<", $filename) or die "Failed to open $filename: $!\n"; binmode $in; if ($filename =~ /^([^\.]{1,8})/) { $file->{'name'} //= uc $1; } return $in; } # Raw binary: just slurp data into one segment sub read_raw { my ($filename,$file) = @_; $file //= {}; my $in = open_file($filename, $file); my %segment = ( 'start' => 0, 'size' => 0, 'data' => "", ); my $data; my $rsize; do { $rsize = read $in, $data, 0x10000; $segment{'data'} .= $data; $segment{'size'} += $rsize; } while ($rsize == 0x10000); $file->{'segments'} = [ \%segment ]; close $in; return $file; } # DragonDOS binary - single segment only sub read_dragondos { my ($filename,$file) = @_; my $in = open_file($filename, $file); getc($in); # skip $55 my $type = unpack("C", getc($in)); my $start = (unpack("C", getc($in)) << 8) | unpack("C", getc($in)); my $size = (unpack("C", getc($in)) << 8) | unpack("C", getc($in)); my $exec = (unpack("C", getc($in)) << 8) | unpack("C", getc($in)); getc($in); # skip $aa my $data; my $rsize = read $in, $data, $size; if ($rsize != $size) { print STDERR "Warning: short read from DragonDOS binary\n"; } my %segment = ( 'start' => $start, 'data' => $data, 'size' => $rsize, ); $file->{'segments'} = [ \%segment ]; close $in; $file->{'type'} //= $ddos_to_tape_type{$type} // TYPE_BINARY; $file->{'exec'} //= $exec; return $file; } # CoCo (DECB) - binaries can contain multiple segments # BASIC files are: $ff size>>8 size data* # BINARY files are: ($00 size>>8 size data*)+ $ff 00 00 exec>>8 exec # (binaries can contain multiple segments) sub read_coco { my ($filename,$file) = @_; my $in = open_file($filename, $file); my $type; my $exec; while (my $stype = getc($in)) { $stype = unpack("C", $stype); my $start; my $size = (unpack("C", getc($in)) << 8) | unpack("C", getc($in)); if ($stype == 0x00) { $type //= TYPE_BINARY; $start = (unpack("C", getc($in)) << 8) | unpack("C", getc($in)); } elsif (!defined $type && $stype == 0xff) { $type = TYPE_BASIC; $start = 0; $exec = 0; } elsif ($stype == 0xff) { if ($size != 0) { # XXX is this dodgy? printf STDERR "Warning: EXEC segment with non-zero size in CoCo binary\n"; } $exec = (unpack("C", getc($in)) << 8) | unpack("C", getc($in)); } else { printf STDERR "Warning: skipping data in CoCo binary\n"; last; } if ($size > 0) { my $data; my $rsize = read $in, $data, $size; if ($rsize != $size) { print STDERR "Warning: short read from CoCo binary\n"; } push @{$file->{'segments'}}, { 'start' => $start, 'data' => $data, 'size' => $rsize, }; } } close $in; $file->{'type'} //= $type // TYPE_BINARY; $file->{'exec'} //= $exec if (defined $exec); return $file; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Replace zero or more segments with exactly one zero-padded segment. All # other file information preserved. sub coalesce_file { my $file = shift; return if (exists $file->{'segments'} && scalar(@{$file->{'segments'}}) == 1); my $old_segments = $file->{'segments'} // []; my %segment = (); my $end; for my $s (sort { $a->{'start'} <=> $b->{'start'} } @{$old_segments}) { my $start = $s->{'start'}; $segment{'start'} //= $start; $end //= $start; my $size = bytes::length($s->{'data'}); my $new_end = $start + $size; # TODO if ($start < $end) { die "Can't handle overlapping segments\n"; } # TODO if ($end >= 0x10000) { die "Segment too large\n"; } if ($start > $end) { $segment{'data'} .= "\0" x ($start - $end); } $segment{'data'} .= $s->{'data'}; $end = $new_end; } $segment{'data'} //= ""; $segment{'start'} //= 0; $end //= $segment{'start'}; $segment{'size'} = $end - $segment{'start'}; $file->{'segments'} = [ \%segment ]; } # Pass file data to dzip. Replaces data, preserves original file metadata and # "osize" records original data size. sub dzip_file { my $file = shift; coalesce_file($file); # single-segment only my $segment = $file->{'segments'}[0]; my $osize = $segment->{'size'} // bytes::length($segment->{'data'}); my $zdata = ""; my $cfd; my $tmp_filename; if ($^O eq 'MSWin32') { # So windows doesn't support forked pipes or list open(). Ack! # Ok, write binary to a temporary file, dzip it, then read in # the results. This is dumb. my $tmp_dir = tempdir(CLEANUP => 1); # auto-clean on exit my $tmp_fd; ($tmp_fd, $tmp_filename) = tempfile(DIR => $tmp_dir); binmode $tmp_fd; print $tmp_fd $segment->{'data'}; close $tmp_fd; my $opts = $reverse_dzip ? "-rk" : "-k"; system("dzip", $opts, $tmp_filename); open($cfd, "<", "$tmp_filename.dz") or die "Can't open dzipped tempfile\n"; } else { # For everything else, just pass the binary out to a fork # running dzip. No race. my $pid = open($cfd, "-|") // die "Failed to open pipe to dzip\n"; if ($pid == 0) { my $opts = $reverse_dzip ? "-rc" : "-c"; open(my $zfd, "|-", "dzip", $opts) // exit 0; binmode $zfd; print $zfd $segment->{'data'}; close $zfd; exit 0; } } binmode $cfd; { local $/ = undef; $zdata = <$cfd>; } close $cfd; if ($^O eq 'MSWin32') { unlink "$tmp_filename.dz"; } # reposition... my $zsize = bytes::length($zdata); die "No data from pipe to dzip\n" unless ($zsize > 0); $segment->{'dzip'} = 1; $segment->{'zx0'} = 0; $segment->{'data'} = $zdata; $segment->{'size'} = $zsize; $segment->{'osize'} = $osize; if ($reverse_dzip) { $segment->{'zoffset'} = rdzip_delta(\$zdata); } else { $segment->{'zoffset'} = dzip_delta(\$zdata); } } # Skim through zipped data. The number of consecutive runs at the end of the # zipped data is the number of bytes required to not overlap. sub dzip_delta { my $zdata = shift; my @data = unpack("C*", $$zdata); my $length = scalar(@data); my $delta = 0; my $max_delta = 0; my $i = 0; while ($i < $length) { my $a = $data[$i++]; if ($a & 0x80) { $max_delta = $delta if ($delta > $max_delta); $delta = 0; if ($data[$i] & 0x80) { $i++; } $i++; } else { $delta++; $i += (128 - $a); } } return $max_delta; } sub rdzip_delta { my $zdata = shift; my @data = unpack("C*", $$zdata); my $length = scalar(@data); my $delta = 0; my $i = $length; while ($i > 0) { $i -= 2; my $a = $data[$i]; if ($a & 0x80) { $delta = 0; if ($data[$i] & 0x80) { $i--; } } else { $delta++; $i -= (127 - $a); } } return $delta; } # ZX0 handling sub zx0_file { my $file = shift; coalesce_file($file); # single-segment only my $segment = $file->{'segments'}[0]; my $osize = $segment->{'size'} // bytes::length($segment->{'data'}); my $zdata = ""; my $cfd; my $tmp_filename; # None of the ZX0 compressors seem to work with standard input, so we # have to go the temp file route. my $tmp_dir = tempdir(CLEANUP => 1); # auto-clean on exit my $tmp_fd; ($tmp_fd, $tmp_filename) = tempfile(DIR => $tmp_dir); binmode $tmp_fd; print $tmp_fd $segment->{'data'}; close $tmp_fd; my $opts = $reverse_dzip ? "-rk" : "-k"; system("salvador", "-classic", $tmp_filename, "$tmp_filename.zx0"); #system("zx0", "-c", $tmp_filename, "$tmp_filename.zx0"); open($cfd, "<", "$tmp_filename.zx0") or die "Can't open ZX0 compressed tempfile\n"; binmode $cfd; { local $/ = undef; $zdata = <$cfd>; } close $cfd; unlink "$tmp_filename.zx0"; # reposition... my $zsize = bytes::length($zdata); die "No data from ZX0\n" unless ($zsize > 0); $segment->{'zx0'} = 1; $segment->{'dzip'} = 0; $segment->{'data'} = $zdata; $segment->{'size'} = $zsize; $segment->{'osize'} = $osize; $segment->{'zoffset'} = zx0_delta(\$zdata) + $zsize - $osize; } sub zx0_elias { my $ctx = shift; my $value = 1; while (!zx0_read_bit($ctx)) { my $bit = zx0_read_bit($ctx); return undef unless defined $bit; $value = ($value << 1) | $bit; } return $value; } sub zx0_read_bit { my $ctx = shift; if ($$ctx{backtrack}) { $$ctx{backtrack} = 0; return $$ctx{last_byte} & 1; } $$ctx{bit_mask} >>= 1; if ($$ctx{bit_mask} == 0) { $$ctx{bit_mask} = 0x80; $$ctx{bit_value} = zx0_read_byte($ctx); return undef unless (defined $$ctx{bit_value}); } return ($$ctx{bit_value} & $$ctx{bit_mask}) ? 1 : 0; } sub zx0_read_byte { my $ctx = shift; $$ctx{last_byte} = $$ctx{data}->[$$ctx{in_bytes}++]; if (!defined $$ctx{last_byte}) { warn "zx0_read_byte(): undefined data; read past end of input?\n"; } return $$ctx{last_byte}; } sub zx0_delta { my $zdata = shift; my $ctx = { data => [ unpack("C*", $$zdata) ], in_bytes => 0, nbytes => 0, backtrack => 0, last_byte => 0, bit_value => 0, bit_mask => 0, }; my $num_input_bytes = scalar(@{$$ctx{data}}); my $max_delta = 0; my $out_bytes = 0; my $state = ZX0_COPY_LITERALS; while (1) { if ($state == ZX0_COPY_LITERALS) { my $length = zx0_elias($ctx); for (my $i = 0; $i < $length; $i++) { last unless defined zx0_read_byte($ctx); } $out_bytes += $length; my $bit = zx0_read_bit($ctx); if (!defined $bit) { last; } elsif ($bit) { $state = ZX0_COPY_FROM_NEW_OFFSET; } else { $state = ZX0_COPY_FROM_LAST_OFFSET; } } elsif ($state == ZX0_COPY_FROM_LAST_OFFSET) { # in the real decompress code, this state is just # merged into the end of ZX0_COPY_LITERALS, as that's # the only place from which it can be reached my $length = zx0_elias($ctx); $out_bytes += $length; my $delta = $out_bytes - $$ctx{in_bytes}; if ($delta > $max_delta) { $max_delta = $delta; } my $bit = zx0_read_bit($ctx); if (!defined $bit) { last; } elsif ($bit) { $state = ZX0_COPY_FROM_NEW_OFFSET; } else { $state = ZX0_COPY_LITERALS; } } elsif ($state == ZX0_COPY_FROM_NEW_OFFSET) { my $offset = zx0_elias($ctx); if ($offset == 256) { if ($$ctx{in_bytes} != $num_input_bytes) { warn "zx0_delta(): did not parse whole input\n"; } last; } # this is the "proper" offset calculation, even if # we're not actually going to use it $offset = ($offset << 7) - (zx0_read_byte($ctx) >> 1); $$ctx{backtrack} = 1; my $length = zx0_elias($ctx) + 1; $out_bytes += $length; my $delta = $out_bytes - $$ctx{in_bytes}; if ($delta > $max_delta) { $max_delta = $delta; } my $bit = zx0_read_bit($ctx); if (!defined $bit) { last; } elsif ($bit) { $state = ZX0_COPY_FROM_NEW_OFFSET; } else { $state = ZX0_COPY_LITERALS; } } else { die "zx0_delta reached invalid state\n"; } } return $max_delta; } # Vertical XOR sub vxor_file { my $file = shift; coalesce_file($file); # single-segment only my $segment = $file->{'segments'}[0]; my $size = $segment->{'size'} // bytes::length($segment->{'data'}); my @vdata = (); my $stride = $want_vxor; my @vxor = (0) x $stride; for my $i (0..$size-1) { my $c = unpack("C", substr($segment->{'data'}, $i, 1)); $vdata[$i] = $c ^ $vxor[$i % $stride]; $vxor[$i % $stride] = $c; } $segment->{'vxor'} = 1; $segment->{'stride'} = $stride; $segment->{'data'} = pack("C*", @vdata); } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub set_timing { my $name = shift; $name //= $normal_timing; if ($name eq 'simple' || $name eq 'rom') { $normal_timing = $name; } die "invalid timing name '$name'\n" unless exists $timing_by_name{$name}; $timing = $timing_by_name{$name}; cue_add_timing($timing); } # Write a file. sub write_file { my $file = shift; # defaults $file->{'fnblock'} //= 1; $file->{'eof'} //= 1; set_timing($file->{'timing'}); # XXX only deal with single-segment files coalesce_file(); my $segment0 = $file->{'segments'}[0]; # Write filename block if required. if ($file->{'fnblock'}) { my $name = $file->{'name'} // "BINARY"; my $type = $file->{'type'} // TYPE_BINARY; my $encoding = $file->{'encoding'} // ENCODING_BINARY; my $gap = $file->{'gapped'} ? GAP_TRUE : GAP_FALSE; my $load = $file->{'load'} // $segment0->{'start'} // 0x0e00; my $exec = $file->{'exec'} // $load; my $fndata = sprintf("\%-8s", $name); $fndata .= pack("CCCnn", $type, $encoding, $gap, $exec, $load); write_leader(); block_out(BLOCK_NAMEFILE, $fndata, $file->{'block_fmt'}); } # Write file data. write_leader() if (!$file->{'gapped'} && $file->{'delay'}); my $data = $segment0->{'data'}; my $size = $segment0->{'size'}; my $ptr = 0; while ($size > 0) { write_leader() if ($file->{'gapped'}); my $bsize; if ($file->{'block_size'} > 0 && $size > $file->{'block_size'}) { $bsize = $file->{'block_size'}; } else { $bsize = $size; } $size -= $bsize; if ($size == 0 && $file->{'eof'}) { if ($file->{'eof_data'}) { block_out(BLOCK_EOF, bytes::substr($data, $ptr, $bsize), $file->{'block_fmt'}); } else { block_out(BLOCK_DATA, bytes::substr($data, $ptr, $bsize), $file->{'block_fmt'}); write_leader() if ($file->{'gapped'}); block_out(BLOCK_EOF, "", $file->{'block_fmt'}); } } else { block_out(BLOCK_DATA, bytes::substr($data, $ptr, $bsize), $file->{'block_fmt'}); } $ptr += $bsize; } } # Write an autorun file, using data from a list of files. sub assemble_autorun { my $inhibit_fast = shift; my $files = shift; # Ensure autorun program is stored at normal speed. set_timing(); my $vdg = 0; my $sam_v = 0; my $sam_f = 2; # 0x0400 my $flasher = 0; $mc_label{'flash_addr'} = 0x0400; my $name = $autorun_name // "AUTORUN"; # Construct a special filename block to autorun. This builds the data # out of blocks of code and then "links" it, as the contents can vary # (multiple files to load, fast loading, dunzipping data). # The standard part of the filename block. mcdata_org(0x01da); mcdata_add(\sprintf("\%-8s", $name)); # filename mcdata_add([ TYPE_BINARY, # file type: machine code ENCODING_BINARY, # ascii flag: binary GAP_FALSE, # gap flag: continuous "colon", 0x3a, 0x00, # exec address (convenient ':') 0x00, 0xa6, # load address: BASIC next "load_part_ptr", ">load_part", ]); if ($any_dzip) { mcdata_add([ "dunzip_ptr", ">dunzip", ]); } if ($any_zx0) { mcdata_add([ "unzx0_ptr", ">unzx0", ]); } mcdata_add([ "exec_loader", # main code starts at $01eb or $01ed ]); # Include fast timing setup if necessary. if (!$inhibit_fast && $any_fast && ($wav_out || $cue)) { mcdata_add(\@code_test_arch); mcdata_add(\@code_fast); } # For each file, add loading instructions. my $last_exec = 0; for my $file (@{$files}) { # defaults when autorunning $file->{'fnblock'} //= 0; $file->{'eof_data'} //= 1; # TODO: currently no provision for switching speed mid-load: $file->{'timing'} = 'fast' if ($any_fast); # a "file" might just be some specific code instructions my $code = $file->{'code'} // ""; my $value = $file->{'value'} // 0; if ($code eq "set_vdg") { $value &= 0xf8; if ($vdg != $value) { mcdata_add([ 0x86, $file->{'value'}, # lda #value 0xb7, 0xff, 0x22, # sta >$ff22 ]); } $vdg = $value; } elsif ($code eq "set_sam_v") { for my $i (0..2) { my $bit = (1 << $i); next if ((($sam_v ^ $value) & $bit) == 0); my $addr = 0xc0 + $i * 2; $addr++ if ($value & $bit); mcdata_add([ 0xb7, 0xff, $addr, # sta >$ffxx ]); } $sam_v = $value & 7; } elsif ($code eq "set_sam_f") { for my $i (0..6) { my $bit = (1 << $i); next if ((($sam_f ^ $value) & $bit) == 0); my $addr = 0xc6 + $i * 2; $addr++ if ($value & $bit); mcdata_add([ 0xb7, 0xff, $addr, # sta >$ffxx ]); } $sam_f = $value & 0x7f; $mc_label{'flash_addr'} = $sam_f * 512; } elsif ($code eq "lds") { mcdata_add([ 0x10, 0xce, $value>>8, $value&0xff, # lds #value ]); } elsif ($code eq "poke") { my ($aa,$vv) = split(/,/, $value); my $addr = eval_int($aa); my $val = eval_int($vv); mcdata_add([ 0x86, $val&0xff, # lda #value 0xb7, $addr>>8, $addr&0xff, # sta >addr ]); } elsif ($code eq "memset") { my ($ss,$ee,$vv) = split(/,/, $value); my $saddr = eval_int($ss); my $eaddr = eval_int($ee)+1; # inclusive, but memset uses blo my $val = eval_int($vv); mcdata_add([ 0x8e, $saddr>>8, $saddr&0xff, # ldx #saddr 0xce, $eaddr>>8, $eaddr&0xff, # ldu #eaddr 0x86, $val, # lda #value 0x8d, "\&{'omit'}) { next; } else { my $segment0 = $file->{'segments'}[0]; my $load = $file->{'load'} // $segment0->{'start'}; my $size = $segment0->{'size'}; my $oload = $load; my $osize = $size; if ($segment0->{'dzip'}) { $osize = $segment0->{'osize'}; my $zoffset = $segment0->{'zoffset'}; if ($reverse_dzip) { $load = $file->{'zload'} // $oload - 3; } else { $load = $file->{'zload'} // $oload + $osize + $zoffset - $size; } } elsif ($segment0->{'zx0'}) { $osize = $segment0->{'osize'}; my $zoffset = $segment0->{'zoffset'}; $load = $file->{'zload'} // $oload + $osize + $zoffset - $size; } my $end = $load + $size; my $fflasher = $file->{'flasher'} // 0; if ($flasher && !$fflasher) { mcdata_add(\@code_disable_flasher); } elsif (!$flasher && $fflasher) { mcdata_add(\@code_enable_flasher); } $flasher = $fflasher; mcdata_add([ 0x8e, $load>>8, $load&0xff, # ldx #load 0x8d, "\&{'dzip'}) { mcdata_add([ 0x8e, $load>>8, $load&0xff, # ldx #load 0xcc, $end>>8, $end&0xff, # ldd #end 0xce, $oload>>8, $oload&0xff, # ldu #oload 0x8d, "\&{'dzip'}) { my $end = $oload + $osize; mcdata_add([ 0xcc, $load>>8, $load&0xff, # ldd #load 0xce, $end>>8, $end&0xff, # ldu #end 0x8d, "\&{'zx0'}) { mcdata_add([ 0x8e, $load>>8, $load&0xff, # ldx #load 0xce, $oload>>8, $oload&0xff, # ldu #oload 0x8d, "\&{'vxor'}) { my $stride = $segment0->{'stride'}; my $start = $oload + $stride; my $end = $oload + $osize; mcdata_add([ 0x8e, $start>>8, $start&0xff, # ldx #start 0xa6, 0x88, 0x100-$stride, # lda -stride,x 0xa8, 0x84, # eora ,x 0xa7, 0x80, # sta ,x+ 0x8c, $end>>8, $end&0xff, # cmpx #end 0x25, 0xf4, # blo loop ]); } $last_exec = $file->{'exec'}; } } $mc_label{'exec'} = $autorun_exec // $last_exec // 0; # Finally, JMP to the program. mcdata_add([ 0x7e, ">exec", # jmp exec ]); # Optional and non-optional chunks of code in support of above. mcdata_add(\@code_load_0); mcdata_add(\@code_load_flash) if ($any_flasher); mcdata_add(\@code_load_1); mcdata_add(\@code_memset) if ($any_memset); if ($any_dzip) { if ($reverse_dzip) { mcdata_add(\@code_dunzipr); } else { mcdata_add(\@code_dunzip); } } if ($any_zx0) { mcdata_add(\@code_unzx0); } # Link - replace all symbol references with actual addresses. mcdata_link(); } sub write_autorun { # Write slow filename block. assemble_autorun($cue, @_); # inhibits fast if cue enable write_leader(); block_out(BLOCK_NAMEFILE, $mc_data); # Discard CUE data for slow loader if any parts are fast. if ($cue && $any_fast) { cue_finish_cas_data(); $cue_data = ""; } # Now the data portion of the loader. Tiny, just overwrites "next # basic token with a pointer to that convenient ':' in the filename # block, and makes BASIC JMP to the loader code. mcdata_org(0x00a6); mcdata_add([ ">colon", # fdb colon 0x7e, ">exec_loader", # jmp exec_loader ]); mcdata_link(); write_leader(); block_out(BLOCK_EOF, $mc_data); } sub write_autorun_post { # Generate and prepend fast filename block. if ($cue && $any_fast) { cue_finish_cas_data(); my $old_cue_data = $cue_data; $cue_data = ""; assemble_autorun(0, @_); write_leader(); block_out(BLOCK_NAMEFILE, $mc_data); cue_finish_cas_data(); $cue_data .= $old_cue_data; } } # Write a list of files sub write_all_files { my $files = shift; for my $file (@{$files}) { my $code = (exists $file->{'code'}) ? $file->{'code'} : ""; my $value = $file->{'value'} // 0; if ($code eq 'pause') { write_pause(); } elsif ($code eq '') { write_file($file); } cue_finish_cas_data(); } bytes_out("U", $timing->{'leader'}) if ($leader > 0); } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Variable-length uint31 defined as: # 7-bit 0nnnnnnn # 14-bit 10nnnnnn nnnnnnnn # 21-bit 110nnnnn nnnnnnnn nnnnnnnn # 28-bit 1110nnnn nnnnnnnn nnnnnnnn nnnnnnnn # 31-bit 11110XXX Xnnnnnnn nnnnnnnn nnnnnnnn nnnnnnnn sub pack_vl_uint31 { my ($v) = @_; return undef if ($v < 0); if ($v < 0x80) { return pack("C", $v); } elsif ($v < 0x4000) { return pack("CC", 0x80 | (($v >> 8) & 0x3f), $v & 0xff); } elsif ($v < 0x200000) { return pack("Cn", 0xc0 | (($v >> 16) & 0x1f), $v & 0xffff); } elsif ($v < 0x10000000) { return pack("CCn", 0xe0 | (($v >> 24) & 0x0f), ($v >> 16) & 0xff, $v & 0xffff); } return pack("Cnn", 0xf0, ($v >> 16) & 0x7fff, $v & 0xffff); } sub cue_add_entry { return unless ($cue); my ($type,$data) = @_; my $size = length($data); $cue_data .= pack("C", $type); $cue_data .= pack_vl_uint31($size); $cue_data .= $data; } sub cue_finish_cas_data { my $cue_cas_data_end = tell($out_fd); return if ($cue_cas_data_end == $cue_cas_data_start); cue_add_entry(CUE_DATA, pack("NN", $cue_cas_data_start, $cue_cas_data_end)); $cue_cas_data_start = $cue_cas_data_end; } sub cue_add_timing { my ($timing) = @_; my $cwoff = $timing->{'data'}->[2] + $timing->{'data'}->[3]; my $cw0 = ($timing->{'cycles'}->[0] + $cwoff) * 16; my $cw1 = ($timing->{'cycles'}->[1] + $cwoff) * 16; my $bit0_length = 14318180 / $cw0; my $bit1_length = 14318180 / $cw1; if ($bit0_length == $cue_bit0_length && $bit1_length == $cue_bit1_length) { return; } cue_finish_cas_data(); cue_add_entry(CUE_TIMING, pack("nn", $bit0_length, $bit1_length)); $cue_bit0_length = $bit0_length; $cue_bit1_length = $bit1_length; } sub cue_add_silence { my ($ms) = @_; cue_finish_cas_data(); cue_add_entry(CUE_SILENCE, pack("n", $ms)); } sub cue_add_comment { my ($comment) = @_; cue_finish_cas_data(); cue_add_entry(CUE_COMMENT, $comment); } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub write_pause { if ($wav_out) { sample_out(0x80, 447443); # 14318180 / 16 / 2 $ao_error = 0.5; } else { if ($cue) { cue_add_silence(500); } # emit leader bytes anyway bytes_out("U" x 94, $timing->{'leader'}); # but start next cas data after it if there's a CUE $cue_cas_data_start = tell($out_fd); } } sub write_leader { write_pause(); bytes_out("U" x $leader, $timing->{'leader'}); } sub block_out { my ($btype,$data,$fmt) = @_; $fmt = $fmt_strings{$fmt // 'normal'}; my $bsize = bytes::length($data); if ($bsize > 0xff) { # this generally means the autorun code has grown too large my $over = $bsize - 0xff; warn "Block too large: truncating $over bytes - expect problems\n"; $bsize = 0xff; } my $sum = 0; $adj_period = $timing->{'adj_period'} // 0; $adj = $timing->{'adj'} // 0; $adj_count = 0; for my $c (split(//, $fmt)) { my $eor = 0; $eor = 0xff if ($c eq uc $c); $c = lc $c; if ($c eq 'i') { # block in: leader byte, $3c bytes_out(pack("C*", 0x55, 0x3c), $timing->{'leader'}); } elsif ($c eq 'o') { # block out: leader byte, initial timing bytes_out(pack("C", 0x55), $timing->{'leader0'}); } elsif ($c eq 't') { # block type bytes_out(pack("C", $btype^$eor), $timing->{'type'}); $sum += $btype; } elsif ($c eq 'n') { # block type 0 (namefile) bytes_out(pack("C", 0x00^$eor), $timing->{'type'}); $sum += 0x00; } elsif ($c eq 'b') { # block type 1 (data) bytes_out(pack("C", 0x01^$eor), $timing->{'type'}); $sum += 0x01; } elsif ($c eq 'e') { # block type $ff (eof) bytes_out(pack("C", 0xff^$eor), $timing->{'type'}); $sum += 0xff; } elsif ($c eq 's') { # block size bytes_out(pack("C", $bsize^$eor), $timing->{'size'}); $sum += $bsize; } elsif ($c eq 'c') { # block checksum bytes_out(pack("C", ($sum^$eor)&0xff), $timing->{'size'}); } elsif ($c eq 'd') { # block data (invert not supported yet) bytes_out($data, $timing->{'data0'}, $timing->{'data'}); for (unpack("C*", $data)) { $sum += $_; } } } } sub ao_period { my $cycles = shift; my $period = ($sample_rate * $cycles * 16) / $sam_rate; my $iperiod = int($period); $ao_error += ($period - $iperiod); $iperiod += int($ao_error); $ao_error -= int($ao_error); return $iperiod; } sub bytes_out { my $data = shift; my $pspec = shift; my $delay0 = $pspec->[0]; my $delay1 = $pspec->[1]; if (!$wav_out) { print $out_fd $data; return; } for my $byte (unpack("C*", $data)) { for (0..7) { my $cycles = $timing->{'cycles'}->[$byte &1] / 2; my $p0 = $cycles + $delay0; my $p1 = $cycles + $delay1; if ($adj_count >= $adj_period) { $p0 += $adj; $adj_count = 0; } my $period0 = ao_period($p0); my $period1 = ao_period($p1); print $out_fd sinewave($period0, $period1); $sample_count += $period0 + $period1; $byte >>= 1; $delay0 = $pspec->[2]; $delay1 = $pspec->[3]; } $pspec = shift if (@_); $delay0 = $pspec->[0]; $delay1 = $pspec->[1]; $adj_count++; } } sub sample_out { my $samp = shift; my $cycles = shift; my $period = ao_period($cycles); my $fmt = "C"; if ($bits_per_sample == 16) { $samp = ($samp - 0x80) * 0x100; $fmt = "s"; } print $out_fd pack($fmt, $samp) x $period; $sample_count += $period; } sub sinewave { my $period0 = shift; my $period1 = shift // $period0; if (exists $sinewaves{"$period0,$period1"}) { return $sinewaves{"$period0,$period1"}; } my $fmt = "C*"; my $head = 10 ** (-3/20); # -3dBFS my $mul = 127 * $head; my $off = 128; if ($bits_per_sample == 16) { $fmt = "s*"; $mul = 32767 * $head; $off = 0; } my $sw = pack($fmt, (map { my $v = sin((pi*($_-0.5))/$period0); int(($v * $mul) + $off); } (1..$period0)), (map { my $v = sin(pi+((pi*($_-0.5))/$period1)); int(($v * $mul) + $off - 1); } (1..$period1))); $sinewaves{"$period0,$period1"} = $sw; return $sw; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Initialise machine code data. Note, does not clear label table. sub mcdata_org { $mc_org = shift; $mc_pc = $mc_org; @mc_link = (); $mc_data = ""; } # Add machine code data. sub mcdata_add { my $text = shift; if (ref($text) eq 'ARRAY') { for my $byte (@{$text}) { if ($byte =~ /^[a-z]/) { $mc_label{$byte} = $mc_pc; } elsif ($byte =~ /^\&?/) { $mc_pc += 2; push @mc_link, [ $byte, $mc_pc ]; $mc_data .= "\x00\x00"; } else { $mc_pc++; $mc_data .= pack("C", $byte); } } } elsif (ref($text) eq 'SCALAR') { $mc_data .= $$text; $mc_pc += bytes::length($$text); } } # "Link" the machine code - replace all the entries in @mc_link with computed # values. sub mcdata_link { for my $r (@mc_link) { my $rlabel = $r->[0]; my $pc = $r->[1]; my $off = $pc - $mc_org; if ($rlabel =~ /^(\&)?([<>])(.*)/) { my ($rel,$size,$label) = ($1,$2,$3); my $addr = $mc_label{$label} or die "missing label: $label\n"; $size = ($size eq '<') ? 1 : 2; $off -= $size; $addr -= $pc if ($rel); my $subdata; if ($size == 1) { $subdata = pack("C", $addr & 0xff); } else { $subdata = pack("n", $addr & 0xffff); } bytes::substr($mc_data, $off, $size, $subdata); } } } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub version_text { printf "bin2cas.pl %s\n", VERSION; print <. This is free software: you are free to change and redistribute it. There is NO WARRANTY, to the extent permitted by law. Special exception: Code included in output (such as "dunzip") is not considered to be part of this program, so the GPL doesn't apply to the results. EOF exit 0; } __END__ =encoding utf8 =head1 NAME B - convert binary data to CAS or WAV with optional autorun =head1 SYNOPSIS B [I