├── scdmake_us_pad.bin ├── scdmake_eu_pad.bin ├── scdmake_eu_prop.bin ├── scdmake_jp_prop.bin ├── scdmake_us_prop.bin ├── scdmake_jp_pad.bin ├── scdget ├── README.TXT ├── scdlittle2bigword ├── scd68kdcleanup ├── scdchecksum ├── scdpalorder ├── scdvdphelp ├── scdisofilefromoffset ├── scdupdatebinfile ├── scdfontmapmaker ├── scdbinempty ├── scdpalettemutate ├── scdromchecksumupdate ├── scdhex ├── scdimg2cvid ├── scdextractipsp ├── scdbinsearch ├── scdpatchasm ├── scdasm ├── SCDTools ├── DisPick.pm ├── DisFormat.pm └── Palette.pm ├── scdwrite ├── scdbincuecheck ├── scdwav2pcm ├── scdbrm ├── scdgamegenie ├── scdbin2asmdata ├── scdips ├── scdcinepakencodeframe ├── scdimgvdppalette ├── scdasmall └── scdcinepakencode /scdmake_us_pad.bin: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /scdmake_eu_pad.bin: -------------------------------------------------------------------------------- 1 | ` -------------------------------------------------------------------------------- /scdmake_eu_prop.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/classiccoding/scdtools/HEAD/scdmake_eu_prop.bin -------------------------------------------------------------------------------- /scdmake_jp_prop.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/classiccoding/scdtools/HEAD/scdmake_jp_prop.bin -------------------------------------------------------------------------------- /scdmake_us_prop.bin: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/classiccoding/scdtools/HEAD/scdmake_us_prop.bin -------------------------------------------------------------------------------- /scdmake_jp_pad.bin: -------------------------------------------------------------------------------- 1 | `, -------------------------------------------------------------------------------- /scdget: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | # make an iso out of a sega cd in the cdrom 20 | # * only supports 1 track sega cds for now, haven't tried more complex ones 21 | ############################################################################### 22 | 23 | # use mount to determine (most likely /dev/sr0 or old machine /dev/hdc) 24 | dd if=/dev/cdrom of=cdrom.iso 25 | 26 | #cdrdao read-cd --read-raw --datafile cdrom.bin --device ATAPI:0,0,0 --driver generic-mmc-raw cdrom.cue 27 | -------------------------------------------------------------------------------- /README.TXT: -------------------------------------------------------------------------------- 1 | scd68kdcleanup 2 | Kind of cleans up output from 68kd (68k disassembler) 3 | scdasm 4 | Wrapper for your favorite assembler and favorite options 5 | scdasmall 6 | Run asmx, asm68k, and SNASM68K and verify they have the same output 7 | scdbin2asmdata 8 | Convert binary data to asm data streams 9 | scdchecksum 10 | A specific tool to make a 16 bit checksum for all but first two bytes 11 | and put the 16 bit checksum at the first two bytes of the file. 12 | Used for a specific homebrew game. 13 | scdcinepakencode 14 | Encode a cinepak file 15 | scdcinepakencodeframe 16 | Encode the image data for a cinepak frame 17 | scdextractipsp 18 | Extract IP and SP from an ISO. 19 | scdget 20 | Retreive the iso for the Sega CD in your CD-ROM 21 | Uses dd program 22 | scdhex 23 | Does a search and replace using hex strings (I used for Sonic CD hacking) 24 | scdimg2tile 25 | Converts an image to Sega VDP data 26 | Uses Perl's Image::Magick library 27 | scdimgvdppalette 28 | TODO work in progress 29 | scdisofilefromoffset 30 | Determines the filename from which an ISO byte index corresponds to 31 | Uses isoinfo program 32 | scdlittle2bigword 33 | I used this to convert cram part of savestate file the more convient endian 34 | scdmake 35 | Used to make a Sega CD ISO 36 | scdmoviedecode 37 | Used to decode a Cinepak for Sega file 38 | scdtile2img 39 | Converts Sega VDP data to a PNG 40 | scdupdatebinfile 41 | Takes a binary file and replaces it at a specified byte index in a file. 42 | Useful for overwriting data in an ISO file. 43 | scdwav2pcm 44 | Converts a wav file to Sega CD PCM data 45 | scdwrite 46 | Writes Sega CD files out to a CD-R 47 | -------------------------------------------------------------------------------- /scdlittle2bigword: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | # I used this to convert cram part of savestate file the more convient endian 20 | ############################################################################### 21 | 22 | use strict; 23 | use warnings; 24 | 25 | if ( $#ARGV < 0 ) { 26 | &Help(); 27 | } 28 | 29 | foreach my $file (@ARGV) { 30 | if ( open( FILE, $file ) ) { 31 | binmode FILE; 32 | 33 | my $result = ''; 34 | my $buffer = ''; 35 | 36 | while (1) { 37 | read( FILE, $buffer, 2 ); 38 | if ( length($buffer) != 2 ) { 39 | last; 40 | } 41 | $result .= substr($buffer,1,1) . substr($buffer,0,1); 42 | } 43 | 44 | close FILE; 45 | 46 | if ( open( FILE, ">$file") ) { 47 | print FILE $result; 48 | } 49 | } 50 | 51 | close FILE; 52 | } 53 | 54 | sub Help { 55 | die ' 56 | scdlittle2bigword 57 | 58 | [description] 59 | Convert from little endian words to big endian words. Used to covert CRAM 60 | part of a savestate to a more convient endian. 61 | 62 | '; 63 | } 64 | -------------------------------------------------------------------------------- /scd68kdcleanup: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | use strict; 20 | use warnings; 21 | 22 | if ( $#ARGV != 0 ) { 23 | &Help(); 24 | } 25 | 26 | open( DIS, '<'.$ARGV[0] ); 27 | while ( my $line = ) { 28 | # reformat each line so it can be assembled before updated by hand 29 | if ( $line =~ m/^(0x[0-9A-F]+):\s+((0x[0-9A-F]{4}\s+)+)(.*)$/ ) { 30 | my $label = $1; 31 | my $values = $2; 32 | my $dis = $4; 33 | $values =~ s/\s+$//g; 34 | chomp $dis; 35 | $values =~ s/\s+0x/,0x/g; 36 | $line = "\t;; $label:\n\t;; $dis\n\tdc.w $values\n"; 37 | } 38 | # SNASM68K does not accept (x,y) and (x,y,z) formats 39 | # it accepts x(y) and x(y,z) though 40 | $line =~ s/([\s,])\((-?0x[0-9A-F]+),([^,\)]+)\)/$1$2($3)/g; 41 | $line =~ s/([\s,])\((-?0x[0-9A-F]+),([^,\)]+),([^,\)]+)\)/$1$2($3,$4)/g; 42 | print $line; 43 | } 44 | close DIS; 45 | 46 | sub Help { 47 | die ' 48 | scd68kdcleanup 49 | 50 | [description] 51 | cleans up the output from 68kd (a 68000 disassembler) to make it quicker 52 | to work on the disassmbly 53 | 54 | '; 55 | } 56 | -------------------------------------------------------------------------------- /scdchecksum: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | use strict; 21 | use warnings; 22 | 23 | if ( $#ARGV < 0 ) { 24 | &Help(); 25 | } 26 | 27 | # TODO a more generic checksummer? 28 | 29 | foreach my $file (@ARGV) { 30 | open( BIN, "<$file" ) or die "Cannot read $file\n"; 31 | binmode BIN; 32 | my $size = -s $file; 33 | my $buffer = ''; 34 | if ( ! read(BIN,$buffer,$size) ) { 35 | die "Cannot read $file\n"; 36 | } 37 | close BIN; 38 | my $sum = 0x0000; 39 | for ( my $i = 2; $i < $size-1; $i += 2 ) { 40 | $sum += unpack("n",substr($buffer,$i,2)); 41 | } 42 | substr($buffer,0,2) = pack("n",$sum); 43 | open( BIN, ">$file" ) or die "Cannot write $file\n"; 44 | binmode BIN; 45 | print BIN $buffer; 46 | close BIN; 47 | } 48 | 49 | sub Help { 50 | die ' 51 | scdchecksum 52 | 53 | [description] 54 | Computes a 16 bit checksum on all the 16 bit pairs in the file except the 55 | first 16 bit pair. It replaces the first 16 bit pair with the computed 56 | checksum. Was originally written for error handling on Sega CD file reading. 57 | 58 | '; 59 | } 60 | -------------------------------------------------------------------------------- /scdpalorder: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | use strict; 21 | use warnings; 22 | 23 | use FindBin; 24 | use lib $FindBin::Bin; 25 | use SCDTools::Palette; 26 | 27 | my $palette = SCDTools::Palette->new(); 28 | my $palette2 = SCDTools::Palette->new(); 29 | 30 | foreach my $arg (@ARGV) { 31 | if ( $palette->ParseArg($arg) ) { 32 | # do nothing 33 | } elsif ( -e $arg ) { 34 | $palette2->{'fileInput'} = $arg; 35 | } else { 36 | print STDERR "\nCould not parse argument: $arg\n"; 37 | &Help(); 38 | } 39 | } 40 | 41 | $palette->ReadPalette(); 42 | $palette2->ReadPalette(); 43 | 44 | my @indexesUnused; 45 | 46 | for ( my $index = 0; $index < $palette->GetColorsCountRead(); $index++ ) { 47 | my $color = $palette->GetColor($index); 48 | if ( $palette2->GetColorIndexWithNoAdding($color) < 0 ) { 49 | unshift @indexesUnused, $index; 50 | } 51 | } 52 | 53 | for ( my $index2 = 0; $index2 < $palette2->GetColorsCountRead(); $index2++ ) { 54 | my $color = $palette2->GetColor($index2); 55 | if ( $palette->GetColorIndexWithNoAdding($color) < 0 ) { 56 | if ( $#indexesUnused >= 0 ) { 57 | my $index = shift @indexesUnused; 58 | $palette->SetColor($index,$color); 59 | } else { 60 | $palette->AddColor($color); 61 | } 62 | } 63 | } 64 | 65 | $palette->OutputPalette(); 66 | -------------------------------------------------------------------------------- /scdvdphelp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | 4 | use strict; 5 | use warnings; 6 | 7 | if ( $#ARGV != 0 ) { 8 | &Help(); 9 | } 10 | 11 | my $value = $ARGV[0]; 12 | 13 | if ( $value =~ m/^\s*w\s*(?:0x|\$|)([0-9A-F]{8})\s*$/i ) { 14 | my $value = hex($1); 15 | my $code = 16 | ( ( $value & 0x000000F0) >> ( 4-2) ) | 17 | ( ( $value & 0xC0000000) >> (30-0) ); 18 | my $address = 19 | ( ( $value & 0x00000003) << (14-0) ) | 20 | ( ( $value & 0x3FFF0000) >> (16-0) ); 21 | my $type = '?'; 22 | my $rw = ($code & 0x01) ? 'Write' : 'Read'; 23 | my $dma = (($code & 0x30) >> 4); 24 | if ( ( $code & 0x0E ) == 0 ) { 25 | $type = 'VRAM'; 26 | } elsif ( ( $code & 0x0E ) == 2 ) { 27 | $type = 'CRAM'; 28 | } elsif ( ( $code & 0x0E ) == 4 ) { 29 | $type = 'VSRAM'; 30 | } elsif ( ( $code & 0x0E ) == 8 ) { 31 | $type = 'CRAM'; 32 | } 33 | printf("Type: %s, R/W: %s, DMA: %d, Code: %2.2X, Address %4.4X\n",$type,$rw,$dma,$code,$address); 34 | } elsif ( $value =~ m/^\s*([wr])\s*(vram|cram|sram)\s*(?:0x|\$|)([0-9A-F]{4})\s*$/i ) { 35 | my $rw = $1; 36 | my $ram = $2; 37 | my $address = hex($3); 38 | my $code = 0; 39 | $code |= ( lc($rw) eq 'w' ? 1 : 0 ); 40 | if ( lc($ram) eq 'vram' ) { 41 | $code |= 0; 42 | } elsif ( lc($ram) eq 'cram' ) { 43 | if ( $code & 1 ) { 44 | $code |= 2; 45 | } else { 46 | $code |= 8; 47 | } 48 | } elsif ( lc($ram) eq 'sram' ) { 49 | $code |= 4; 50 | } else { 51 | die "Bad regexp to if logic\n"; 52 | } 53 | my $value = 54 | ( ( $address >> 14 ) & 0x00000003 ) | 55 | ( ( $code << 2 ) & 0x000000F0 ) | 56 | ( ( $address << 16 ) & 0x3FFF0000 ) | 57 | ( ( $code << 30 ) & 0xC0000000 ); 58 | printf("Value: %8.8X\n",$value); 59 | } else { 60 | print "Could not parse $value\n"; 61 | } 62 | 63 | sub Help { 64 | die ' 65 | scdvdphelp [options] 66 | 67 | [description] 68 | Help with the VDP. 69 | 70 | [options] 71 | w0xXXXXXXXX detail what this VDP write does 72 | wvram0xXXXX write vram 73 | rvram0xXXXX read vram 74 | wcram0xXXXX write cram 75 | rcram0xXXXX read cram 76 | wsram0xXXXX write sram 77 | rsram0xXXXX read sram 78 | 79 | '; 80 | } 81 | -------------------------------------------------------------------------------- /scdisofilefromoffset: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | use strict; 21 | use warnings; 22 | 23 | # TODO cheap and use isoinfo, make platform independent 24 | 25 | if ( $#ARGV != 1 ) { 26 | &Help(); 27 | } 28 | 29 | my $iso = $ARGV[0]; 30 | my $isoIndex = $ARGV[1]; 31 | if ( $isoIndex =~ /^0x(.+)$/ ) { 32 | $isoIndex = hex($1); 33 | } 34 | 35 | my @found; 36 | 37 | if ( open( PIPE, "isoinfo -l -i \"$iso\" |" ) ) { 38 | while ( my $line = ) { 39 | if ( $line =~ /^\S+\s+\S+\s+\S+\s+\S+\s+(\d+)\s+[^\[]+\[\s*(\d+)\s+0+\s*\]\s+(\S+)\s*$/ ) { 40 | my $fileSize = $1; 41 | my $fileStartSector = $2; 42 | my $fileName = $3; 43 | #print "$fileSize $fileStartSector $fileName\n"; 44 | my $fileStart = $fileStartSector * 0x800; 45 | if ( $isoIndex >= $fileStart && 46 | $isoIndex < $fileStart + $fileSize ) { 47 | my $offset = $isoIndex - $fileStart; 48 | push @found, "$fileName:$offset"; 49 | } 50 | } 51 | } 52 | } 53 | close PIPE; 54 | 55 | if ( $#found > 0 ) { 56 | print "file_found_in_multiple_files\n"; 57 | } elsif ( $#found < 0 ) { 58 | print "file_not_found\n"; 59 | } else { 60 | print $found[0]."\n"; 61 | } 62 | 63 | sub Help { 64 | die ' 65 | scdisofilefromoffset [isofile] [isoindex] 66 | 67 | [description] 68 | given an ISO and an byte index into the ISO, report the file name and file 69 | offset of where the file that is located at that byte index 70 | 71 | '; 72 | } 73 | -------------------------------------------------------------------------------- /scdupdatebinfile: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | # replace part of a binary file with the contents of another binary file 20 | ############################################################################### 21 | 22 | use strict; 23 | use warnings; 24 | 25 | if ( $#ARGV != 2 ) { 26 | &Help(); 27 | } 28 | 29 | my $updateFileName = $ARGV[0]; 30 | my $updateOffset = $ARGV[1]; 31 | my $replaceFileName = $ARGV[2]; 32 | 33 | if ( $updateOffset =~ m/^(\$|0x)([0-9A-F]+)$/ ) { 34 | $updateOffset = hex($2); 35 | } 36 | 37 | my $replaceFileSize = -s $replaceFileName; 38 | 39 | if ( $replaceFileSize <= 0 ) { 40 | exit; 41 | } 42 | 43 | # TODO only replace part of the file as needed when I wanted to replace 44 | # the SCD fun part of the ISO 45 | # $replaceFileSize = 0x8000; 46 | 47 | open( REPLACE, "<$replaceFileName" ) or die "Cannot read $replaceFileName\n"; 48 | 49 | my $replaceFileData = ''; 50 | if ( read( REPLACE, $replaceFileData, $replaceFileSize ) != $replaceFileSize ) { 51 | die "Cannot read all of $replaceFileName\n"; 52 | } 53 | 54 | close REPLACE; 55 | 56 | open( UPDATE, "+<$updateFileName" ) or die "Cannot update $updateFileName\n"; 57 | seek( UPDATE, $updateOffset, 0 ); 58 | 59 | print UPDATE $replaceFileData; 60 | 61 | close UPDATE; 62 | 63 | sub Help { 64 | die ' 65 | scdupdatebinfile 66 | 67 | [description] 68 | Replace part of a with the contents from at byte 69 | position . Useful for overriding files in an ISO. 70 | 71 | '; 72 | } 73 | -------------------------------------------------------------------------------- /scdfontmapmaker: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | ############################################################################### 3 | # Copyright (c) 2014 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | # convert images to asm files for megadrive/megacd development 20 | ############################################################################### 21 | 22 | use strict; 23 | use warnings; 24 | 25 | my $fontText = ''; 26 | my $text = ''; 27 | my $mapWidth = 1; 28 | 29 | foreach my $arg (@ARGV) { 30 | if ( $arg =~ m/^-fonttext=(.+)$/ ) { 31 | $fontText = $1; 32 | } elsif ( $arg =~ m/^-text=(.+)$/ ) { 33 | $text = $1; 34 | } elsif ( $arg =~ m/^-mapwidth=([12])$/ ) { 35 | $mapWidth = hex($1); 36 | } else { 37 | print STDERR "\nCould not parse argument: $arg\n"; 38 | &Help(); 39 | } 40 | } 41 | 42 | if ( $text eq '' || 43 | $fontText eq '' ) { 44 | &Help(); 45 | } 46 | 47 | my $textLength = length($text); 48 | for ( my $i = 0; $i < $textLength; $i++ ) { 49 | my $character = substr($text,$i,1); 50 | my $index = index($fontText,$character); 51 | if ( $index < 0 ) { 52 | die "font does not contain character: $character\n"; 53 | } 54 | if ( $mapWidth == 1 ) { 55 | if ( $index > 0xFF ) { 56 | die "Bad font index for map width of one\n"; 57 | } 58 | printf("\tdc.b\t\$%2.2X\n",$index); 59 | } else { 60 | if ( $index > 0x7FF ) { 61 | die "Bad font index for map width of two\n"; 62 | } 63 | printf("\tdc.w\t\$%2.2X\n",$index); 64 | } 65 | } 66 | 67 | 68 | 69 | sub Help { 70 | die ' 71 | scdfontmapmaker 72 | 73 | [description] 74 | make tile maps targetted easy usage of font maps 75 | 76 | [options] 77 | -fonttext=text text in order of font tiles 78 | -text=text text you want to convert into tile map 79 | 80 | '; 81 | } 82 | -------------------------------------------------------------------------------- /scdbinempty: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2014 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | # replace part of a binary file with the contents of another binary file 20 | ############################################################################### 21 | 22 | use strict; 23 | use warnings; 24 | 25 | if ( $#ARGV != 2 ) { 26 | &Help(); 27 | } 28 | 29 | my $type = $ARGV[0]; 30 | my $fileName = $ARGV[1]; 31 | my $length = $ARGV[2]; 32 | 33 | if ( $length =~ m/^(\$|0x)([0-9A-F]+)$/ ) { 34 | $length = hex($2); 35 | } 36 | 37 | my $data; 38 | if ( $type =~ m/^00$/i ) { 39 | $data = chr(0x00) x $length; 40 | } elsif ( $type =~ m/^ff$/i ) { 41 | $data = chr(0xFF) x $length; 42 | } elsif ( $type =~ m/^([0-9A-F]){2}$/i ) { 43 | $data = chr(hex($type)) x $length; 44 | } elsif ( $type =~ m/^([0-9A-F]){4}$/i ) { 45 | $data = substr(((chr(hex(substr($type,0,2))).chr(hex(substr($type,2,2)))) x (($length+1)>>1)),0,$length); 46 | } elsif ( $type =~ m/^tilepattern$/i ) { 47 | $data = substr(((chr(0x01).chr(0x23).chr(0x45).chr(0x67).chr(0x89).chr(0xAB).chr(0xCD).chr(0xEF)) x (($length+7)>>3)),0,$length); 48 | } else { 49 | die "invalid type: $type\n"; 50 | } 51 | 52 | open( FILE, ">$fileName" ) or die "Cannot write $fileName\n"; 53 | binmode FILE; 54 | print FILE $data; 55 | close FILE; 56 | 57 | sub Help { 58 | die ' 59 | scdbinempty 60 | 61 | [description] 62 | Make a file with zeros of size length 63 | 64 | 00 fill with 0x00 65 | ff fill with 0xFF 66 | xx fill with hexadecimal byte 67 | xxxx fill with hexadecimal byte pair 68 | tilepattern fill with 0x0123456789ABCDEF 69 | 70 | '; 71 | } 72 | -------------------------------------------------------------------------------- /scdpalettemutate: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | ############################################################################### 3 | # Copyright (c) 2012 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | # convert images to asm files for megadrive/megacd development 20 | ############################################################################### 21 | 22 | use strict; 23 | use warnings; 24 | 25 | use FindBin; 26 | use lib $FindBin::Bin; 27 | use SCDTools::Palette; 28 | 29 | my $palette = SCDTools::Palette->new(); 30 | my $verbosity = 2; 31 | 32 | if ( $#ARGV < 0 ) { 33 | &Help(); 34 | } 35 | 36 | my $convertType = 'none'; 37 | 38 | foreach my $arg (@ARGV) { 39 | if ( $palette->ParseArg($arg) ) { 40 | # do nothing 41 | } elsif ( $arg =~ /^-v=(\d+)$/i ) { 42 | $verbosity = $1; 43 | } elsif ( $arg =~ /^-convert=(\S+)$/i ) { 44 | $convertType = $1; 45 | } else { 46 | print STDERR "\nCould not parse argument: $arg\n"; 47 | &Help(); 48 | } 49 | } 50 | 51 | $palette->ReadPalette(); 52 | $palette->Convert($convertType); 53 | $palette->OutputPalette(); 54 | 55 | ############################################################################### 56 | 57 | sub Help { 58 | die ' 59 | scdpalettemutate [options] 60 | 61 | [description] 62 | convert a palette from assembly/binary with optional color conversion and 63 | output assembly/binary palette 64 | 65 | '.$palette->GetHelpString().'[options] 66 | -convert= convert palette 67 | greyavg: convert to greyscale 68 | desaturate50: desaturate by 50% 69 | invert: invert colors 70 | redonly: zero out green and blue aspects 71 | greenonly: zero out red and blue aspects 72 | blueonly: zero out red and green aspects 73 | -nocomments do not print any comments in out 74 | -nolabels do not print any labels in out 75 | -label= labels use to make useful labels 76 | example: StartTiles: 77 | -v=<#> specify verbosity 78 | 79 | '; 80 | } 81 | -------------------------------------------------------------------------------- /scdromchecksumupdate: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2015 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | use strict; 21 | use warnings; 22 | 23 | if ( $#ARGV < 0 || $#ARGV > 1 ) { 24 | &Help(); 25 | } 26 | 27 | my $romFileIn = $ARGV[0]; 28 | my $romFileOut = $#ARGV < 1 ? '' : $ARGV[1]; 29 | 30 | my $romLength = -s $romFileIn; 31 | my $romData = ''; 32 | 33 | if ( $romLength < 0x200 ) { 34 | printf("file length : 0x%8.8X\n",$romLength); 35 | print STDERR "file not long enough to be a ROM\n"; 36 | } 37 | 38 | open( ROM, $romFileIn ) or die "Could not read file: $romFileIn\n"; 39 | binmode ROM; 40 | read( ROM, $romData, $romLength ); 41 | close ROM; 42 | 43 | my $endOfRomPointer = 0x1A4; 44 | my $checksumPointer = 0x18E; 45 | my $startOfChecksum = 0x200; 46 | 47 | 48 | my $endOfRom = unpack("N",substr($romData,$endOfRomPointer,4)); 49 | my $checksumSaved = unpack("n",substr($romData,$checksumPointer,2)); 50 | 51 | if ( $romLength < $endOfRom+1 ) { 52 | printf("file length : 0x%8.8X\n",$romLength); 53 | printf("rom length : 0x%8.8X\n",$endOfRom); 54 | print STDERR "End of ROM indication outside of end of file\n"; 55 | exit; 56 | } 57 | 58 | my $checksumCurrent = 0; 59 | for (my $address = $startOfChecksum; $address < $endOfRom; $address += 2 ) { 60 | $checksumCurrent += unpack("n",substr($romData,$address,2)); 61 | } 62 | $checksumCurrent &= 0xFFFF; 63 | 64 | if ( $checksumSaved != $checksumCurrent ) { 65 | if ( $romFileOut ne '' ) { 66 | print "Updating checksum\n"; 67 | substr($romData,$checksumPointer,2) = pack("n",$checksumCurrent); 68 | 69 | open( ROM, '>'.$romFileOut ) or die "Could not read file: $romFileOut\n"; 70 | binmode ROM; 71 | print ROM $romData; 72 | close ROM; 73 | } else { 74 | print "Checksum out of date\n"; 75 | } 76 | } 77 | 78 | 79 | sub Help { 80 | die ' 81 | scdromchecksumupdate [romfile] [romfilesave] 82 | 83 | [description] 84 | Updates Genesis ROM word checksum. 85 | Uses addresses between 0x200 and address pointed to by long at 0x1A4. 86 | Checksum is stored at address 0x18E. 87 | 88 | '; 89 | } 90 | -------------------------------------------------------------------------------- /scdhex: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | use strict; 21 | use warnings; 22 | 23 | if ( $#ARGV < 1 ) { 24 | &Help(); 25 | } 26 | 27 | my $cmd = lc(shift @ARGV); 28 | my $tokenSearchString = ''; 29 | my $tokenReplaceString = ''; 30 | 31 | if ( $cmd eq 'search' ) { 32 | if ( $#ARGV < 1 ) { 33 | &Help(); 34 | } 35 | $tokenSearchString = shift @ARGV; 36 | } elsif ( $cmd eq 'replace' ) { 37 | if ( $#ARGV < 2 ) { 38 | &Help(); 39 | } 40 | $tokenSearchString = shift @ARGV; 41 | $tokenReplaceString = shift @ARGV; 42 | } else { 43 | &Help(); 44 | } 45 | 46 | 47 | if ( $tokenSearchString !~ m/^[0-9A-F]*$/i || 48 | $tokenReplaceString !~ m/^[0-9A-F]*$/i ) { 49 | &Help(); 50 | } 51 | 52 | my $updates = 0; 53 | 54 | foreach my $binFile (@ARGV) { 55 | 56 | open( BIN, $binFile ) or die "Cannot read file: $binFile\n"; 57 | 58 | binmode BIN; 59 | 60 | my $binSize = -s $binFile; 61 | 62 | my $binBuffer = ''; 63 | 64 | read( BIN, $binBuffer, $binSize ); 65 | 66 | my $tokenSearch = pack("H*",$tokenSearchString); 67 | my $tokenReplace = pack("H*",$tokenReplaceString); 68 | 69 | my $tokenLength = length($tokenSearch); 70 | 71 | my $modified = 0; 72 | 73 | my $index = 0; 74 | while ( $index >= 0 ) { 75 | $index = index($binBuffer,$tokenSearch,$index); 76 | if ( $index >= 0 ) { 77 | $updates++; 78 | if ( $cmd eq 'search' ) { 79 | printf( "$binFile: %8.8X\n", $index); 80 | $index++; 81 | } elsif ( $cmd eq 'replace' ) { 82 | substr($binBuffer,$index,$tokenLength) = $tokenReplace; 83 | $index += length($tokenReplace); 84 | } 85 | } 86 | } 87 | 88 | close BIN; 89 | 90 | if ( $modified ) { 91 | open( BIN, ">$binFile" ); 92 | print BIN $binBuffer; 93 | close BIN; 94 | } 95 | } 96 | 97 | if ( $cmd eq 'replace' ) { 98 | print "$tokenSearchString -> $tokenReplaceString: $updates\n"; 99 | } 100 | 101 | sub Help { 102 | die ' 103 | scdhex [cmdoptions] 104 | 105 | [description] 106 | Performs search/replace type operations using hexadecimal strings on a binary 107 | file. Was originally developed for simple ISO hacking of Sonic CD. 108 | 109 | [cmd] 110 | search 111 | replace 112 | 113 | [examples] 114 | scdhex search \ 115 | 0000000008220A440C660E880EEE0AAA0888044408AE046A000E0008000400EE R*__.MMD 116 | scdhex replace 427900FF1512 4E714E714E71 R*__.MMD 117 | 118 | '; 119 | } 120 | -------------------------------------------------------------------------------- /scdimg2cvid: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | ############################################################################### 3 | # Copyright (c) 2015 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | # convert images to cvid cinepak frames 20 | ############################################################################### 21 | 22 | use strict; 23 | use warnings; 24 | 25 | use Image::Magick; 26 | 27 | if ( $#ARGV < 0 ) { 28 | &Help(); 29 | } 30 | 31 | 32 | my $img; 33 | my $imgAlpha = 0; 34 | 35 | my @imgFiles; 36 | 37 | foreach my $arg (@ARGV) { 38 | if ( $arg =~ /^-asmtiles=(.*)$/i ) { 39 | # TODO 40 | } elsif ( -e $arg ) { 41 | push @imgFiles, $arg; 42 | } else { 43 | print STDERR "\nCould not parse argument: $arg\n"; 44 | &Help(); 45 | } 46 | } 47 | 48 | if ( $#imgFiles < 0 ) { 49 | print STDERR "\nNeed to specify image files\n"; 50 | &Help(); 51 | } 52 | 53 | # TODO 54 | my $imgFile = $imgFiles[0]; 55 | 56 | 57 | $img = Image::Magick->new(); 58 | my $z = $img->ReadImage($imgFile); 59 | warn $z if $z; 60 | $imgAlpha = $img->Get('matte'); 61 | my $width = $img->Get('width'); 62 | my $height = $img->Get('height'); 63 | 64 | for ( my $x1 = 0 ; $x1 < 4; $x1++ ) { 65 | for ( my $y1 = 0 ; $y1 < 4; $y1++ ) { 66 | my ($y,$u,$v) = &GetYUV($img,$x1,$y1); 67 | # print "xy $x1 x $y1 yuv $y $u $v\n"; 68 | my $y2 = int($y); 69 | my $u2 = int($u); 70 | my $v2 = int($v); 71 | printf("xy %d x %d yuv %2.2X %2.2X %2.2X\n",$x1,$y1,$y2&0xFF,$u2&0xFF,$v2&0xFF); 72 | } 73 | } 74 | 75 | # YUV12 4:2:0 76 | 77 | # | r | | 1.0 0.0 2.0 | | y | 78 | # | g | = | 1.0 -0.5 -1.0 | | u | 79 | # | b | | 1.0 2.0 0.0 | | v | 80 | 81 | # Wr = 0.2857 Wb = 0.1429 82 | # Umax = 0.4286 Vmax = 0.3571 83 | 84 | # | y | | 0.2857 0.5714 0.1429 | | r | 85 | # | u | = | -0.1429 -0.2857 0.4286 | | g | 86 | # | v | | 0.3571 -0.2857 -0.0714 | | b | 87 | 88 | # Wr = 0.299 Wg = 0.587 Wb = 0.114 89 | # 2 = ( 1 - Wb ) / Umax -> Umax = 0.443 90 | # 2 = ( 1 - Wr ) / Vmax -> Vmax = 0.3505 91 | 92 | # | y | | 0.299 0.587 0.114 | | r | 93 | # | u | = | -0.1495 -0.2935 0.443 | | g | 94 | # | v | | 0.3505 -0.2935 -0.057 | | b | 95 | 96 | # y is luma 97 | # u is blue component from red / green 98 | # v is red component from blue / green 99 | 100 | sub GetYUV { 101 | my ($img,$x1,$y1) = @_; 102 | my $a = $img->GetPixel('channel'=>'Alpha','normalize'=>1,'x'=>$x1,'y'=>$y1); 103 | if ( defined $a && $a == 1 ) { 104 | return 0; 105 | } 106 | my ($r,$g,$b) = $img->GetPixel('channel'=>'RGB','normalize'=>1,'x'=>$x1,'y'=>$y1); 107 | 108 | printf("%d %d %d\n",$r*255,$g*255,$b*255); 109 | 110 | # 8 bit unsigned y, 8 bit signed u and v 111 | #my $y = ( 0.2857 * $r + 0.5714 * $g + 0.1429 * $b ) * 255; 112 | #my $u = ( ( - 0.1429 * $r - 0.2857 * $g + 0.4286 * $b ) ) * 127 / ( 0.4286 ); 113 | #my $v = ( ( 0.3571 * $r - 0.2857 * $g - 0.0714 * $b ) ) * 127 / ( 0.3571 ); 114 | #my $y = ( 0.2126 * $r + 0.7152 * $g + 0.0722 * $b ) * 255; 115 | #my $u = ( ( - 0.09991 * $r - 0.33609 * $g + 0.4360 * $b ) ) * 127 / ( 0.4360 ); 116 | #my $v = ( ( 0.615 * $r - 0.55861 * $g - 0.05639 * $b ) ) * 127 / ( 0.615 ); 117 | 118 | #my $yp = ( 0.2857 * $r + 0.5714 * $g + 0.1429 * $b ); 119 | #my $y = 255 * $yp; 120 | #my $u = 127 * ( $b - $y ) / ( 1 - 0.1429 ); 121 | #my $v = 127 * ( $r - $y ) / ( 1 - 0.2857 ); 122 | 123 | # why is this closer than other 124 | my $yp = ( 0.2126 * $r + 0.7152 * $g + 0.0722 * $b ); 125 | my $y = 220 * $yp + 18; 126 | my $u = 112 * ( $b - $yp ) / ( 1 - 0.0722 ); 127 | my $v = 112 * ( $r - $yp ) / ( 1 - 0.2126 ); 128 | 129 | # | y | | 0.299 0.587 0.114 | | r | 130 | # | u | = | -0.1495 -0.2935 0.443 | | g | 131 | # | v | | 0.3505 -0.2935 -0.057 | | b | 132 | my $y = ( 0.299 * $r + 0.587 * $g + 0.114 * $b ) * 220+18; 133 | my $u = ( ( - 0.1495 * $r - 0.2935 * $g + 0.443 * $b ) ) * 112 / ( 0.443 ); 134 | my $v = ( ( 0.3505 * $r - 0.2935 * $g - 0.057 * $b ) ) * 112 / ( 0.3505 ); 135 | 136 | # my $y = int( 76 * $r + 150 * $g + 29 * $b + 0.5 ); 137 | # my $u = int( -43 * $r + -84 * $g + 127 * $b + .5 ); 138 | # my $v = int( 127 * $r + -106 * $g + -21 * $b + .5 ); 139 | 140 | # my $y = int( 76 * $r + 150 * $g + 29 * $b + 0.5 ); 141 | # my $u = int( -43 * $r + -84 * $g + 127 * $b + .5 ); 142 | # my $v = int( 127 * $r + -106 * $g + -21 * $b + .5 ); 143 | 144 | return ($y,$u,$v); 145 | } 146 | -------------------------------------------------------------------------------- /scdextractipsp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2012 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | # TODO support bin/cue format? 21 | 22 | use strict; 23 | use warnings; 24 | 25 | use POSIX qw(SEEK_SET); 26 | 27 | my $verbosity = 2; 28 | my $ipFile = 'IP.BIN'; 29 | my $spFile = 'SP.BIN'; 30 | my $iso = ''; 31 | my $removeTrailingZeros = 0; 32 | 33 | foreach my $arg (@ARGV) { 34 | if ( $arg =~ m/^-v=(\d+)$/i ) { 35 | $verbosity = $1; 36 | } elsif ( $arg =~ m/^-ipfile=(.+)$/i ) { 37 | $ipFile = $1; 38 | } elsif ( $arg =~ m/^-spfile=(.+)$/i ) { 39 | $spFile = $1; 40 | } elsif ( $arg =~ m/^-iponly$/i ) { 41 | $spFile = ''; 42 | } elsif ( $arg =~ m/^-sponly$/i ) { 43 | $ipFile = ''; 44 | } elsif ( $arg =~ m/^-removetrailingzeros$/i ) { 45 | $removeTrailingZeros = 1; 46 | } elsif ( $iso eq '' && -e $arg ) { 47 | $iso = $arg; 48 | } else { 49 | print "Bad argument: $arg\n"; 50 | &Help(); 51 | } 52 | } 53 | 54 | if ( $iso eq '' || 55 | ( $ipFile eq '' && $spFile eq '' ) ) { 56 | &Help(); 57 | } 58 | 59 | if (!open(ISO, $iso)) { 60 | die "Could not open ISO: $iso\n"; 61 | } 62 | 63 | binmode ISO; 64 | 65 | # read values from System ID 66 | my $ipSizeID = &ReadLong(0x34); 67 | my $spStart = &ReadLong(0x40); 68 | my $spSize = &ReadLong(0x44); 69 | 70 | # determine proprietary code size since affects IP start and size 71 | my $propSize = &DetermineProprietarySize(); 72 | 73 | # determine IP start and size accounting for proprietary code 74 | my $ipStart = 0x200+$propSize; 75 | my $ipSize = (0x600-$propSize) + $ipSizeID; 76 | 77 | # read the IP and SP data 78 | my $ipData = &ReadString($ipStart,$ipSize); 79 | my $spData = &ReadString($spStart,$spSize); 80 | 81 | close ISO; 82 | 83 | if ( $removeTrailingZeros ) { 84 | $ipData =~ s/\x00+$//; 85 | my $ipSizeNew = length($ipData); 86 | my $ipSizeDiff = $ipSize - $ipSizeNew; 87 | if ( $ipSizeDiff ) { 88 | print "removed $ipSizeDiff zero bytes from the end of $ipFile\n"; 89 | $ipSize = $ipSizeNew; 90 | } 91 | 92 | $spData =~ s/\x00+$//; 93 | my $spSizeNew = length($spData); 94 | my $spSizeDiff = $spSize - $spSizeNew; 95 | if ( $spSizeDiff ) { 96 | print "removed $spSizeDiff zero bytes from the end of $spFile\n"; 97 | $spSize = $spSizeNew; 98 | } 99 | } 100 | 101 | # now just make the IP.BIN and SP.BIN from the data extracted 102 | &OutputFileFromArea($ipFile,$ipStart,$ipSize,$ipData); 103 | &OutputFileFromArea($spFile,$spStart,$spSize,$spData); 104 | 105 | 106 | 107 | sub OutputFileFromArea { 108 | my ($file,$offset,$size,$data) = @_; 109 | if ( $file ne '' ) { 110 | printf("Making %s from ISO offset \$%8.8X with size \$%8.8X\n",$file,$offset,$size); 111 | if ( ! open(OUTPUT,'>'.$file) ) { 112 | die "Can write file: $file\n"; 113 | } 114 | print OUTPUT $data; 115 | close OUTPUT; 116 | } 117 | } 118 | 119 | sub ReadString { 120 | my ($offset,$size) = @_; 121 | seek(ISO,$offset,SEEK_SET); 122 | my $data = chr(0x00)x$size; 123 | if ( read(ISO,$data,$size) != $size ) { 124 | die "Could not read ISO data\n"; 125 | } 126 | return $data; 127 | } 128 | 129 | sub ReadLong { 130 | my $data = &ReadString($_[0],4); 131 | return unpack("N",$data); 132 | } 133 | 134 | sub ReadByte { 135 | my $data = &ReadString($_[0],1); 136 | return ord($data); 137 | } 138 | 139 | sub DetermineProprietarySize { 140 | # determine proprietary code size by examining the contents of it 141 | # the first different byte between all three regions is 0x20B 142 | # 0x7A (U) 143 | # 0xA1 (J) 144 | # 0x64 (E) 145 | my $data = &ReadByte(0x20B); 146 | my $size = 0; 147 | if ( $data == 0x7A ) { 148 | $size = 0x584; 149 | } elsif ( $data == 0xA1 ) { 150 | $size = 0x156; 151 | } elsif ( $data == 0x64 ) { 152 | $size = 0x56E; 153 | } else { 154 | die "Could not determine region of ISO\n"; 155 | } 156 | } 157 | 158 | 159 | 160 | sub Help { 161 | die ' 162 | scdextractipsp 163 | 164 | [description] 165 | Extracts IP data and SP data from a Sega CD ISO. 166 | 167 | [options] 168 | -ipfile= Name of file to write IP data (defaults IP.BIN) 169 | -spfile= Name of file to write SP data (defaults SP.BIN) 170 | -iponly Only extract IP data 171 | -sponly Only extract SP data 172 | -removetrailingzeros remove the trailing zero bytes at the end of IP/SP 173 | most commercial games had an IP/SP that was mostly zero 174 | 175 | '; 176 | } 177 | -------------------------------------------------------------------------------- /scdbinsearch: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2014 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | use strict; 21 | use warnings; 22 | 23 | my $offset = 0; 24 | my $end = 0; 25 | my $length = 0; 26 | my @files; 27 | 28 | sub ArgNumber { 29 | my ($type,$num) = @_; 30 | my $value = 0; 31 | if ( $num =~ /^(\d+)$/i ) { 32 | $value = $1; 33 | } elsif ( $num =~ /^(0x|\$)([0-9A-F]+)$/i ) { 34 | $value = hex($2); 35 | } else { 36 | die "Bad num logic: ($type,$num)\n"; 37 | } 38 | if ( $type eq '' || $type eq 'byte' ) { 39 | # do nothing 40 | } elsif ( $type eq 'word' ) { 41 | $value *= 2; 42 | } elsif ( $type eq 'long' ) { 43 | $value *= 4; 44 | } elsif ( $type eq 'pal' || $type eq 'tile' ) { 45 | $value *= 32; 46 | } else { 47 | die "Bad type logic: ($type,$num)\n"; 48 | } 49 | return $value; 50 | } 51 | 52 | my $keywordData = ''; 53 | 54 | # parse args 55 | foreach my $arg (@ARGV) { 56 | if ( $arg =~ /^-(|byte|word|long|pal|tile)offset=([\d+|(0x|\$)[0-9A-F]+)$/i ) { 57 | $offset = &ArgNumber($1,$2); 58 | } elsif ( $arg =~ /^-(|byte|word|long|pal|tile)length=([\d+|(0x|\$)[0-9A-F]+)$/i ) { 59 | $length = &ArgNumber($1,$2); 60 | } elsif ( $arg =~ /^-(|byte|word|long|pal|tile)end=([\d+|(0x|\$)[0-9A-F]+)$/i ) { 61 | $end = &ArgNumber($1,$2); 62 | } elsif ( $arg =~ /^-keyword=(0x|\$)([0-9A-F]+)$/i ) { 63 | $keywordData = pack("H*",$2); 64 | } elsif ( -e $arg ) { 65 | push @files, $arg; 66 | } else { 67 | print STDERR "\nCould not parse argument: $arg\n"; 68 | &Help(); 69 | } 70 | } 71 | 72 | if ( $#files < 0 || 73 | ( $keywordData eq '' && $#files < 1 ) ) { 74 | print STDERR "Need to specify some more files\n"; 75 | &Help(); 76 | } 77 | 78 | if ( $keywordData eq '' ) { 79 | my $keywordFile = shift @files; 80 | my $keywordFileSize = -s $keywordFile; 81 | 82 | if ( $end > 0 ) { 83 | if ( $offset >= $end ) { 84 | die "start before end...\n"; 85 | } 86 | my $lengthNew = $end - $offset; 87 | if ( $length > 0 && $length != $lengthNew ) { 88 | die "specified length ($length) doesn't match specified offset ($offset) and specified end ($end)\n"; 89 | } 90 | $length = $lengthNew; 91 | } 92 | if ( $offset + $length > $keywordFileSize ) { 93 | die "Keyword offset/length exceeds keyword file length\n"; 94 | } 95 | if ( $length <= 0 ) { 96 | $length = $keywordFileSize - $offset; 97 | } 98 | if ( ! open(KEYWORD, $keywordFile) ) { 99 | die "Could not properly open keyword file\n"; 100 | } 101 | binmode KEYWORD; 102 | $keywordData = chr(0x00) x $length; 103 | if ( ! seek(KEYWORD,$offset,0) ) { 104 | die "Could not properly find start of keyword data\n"; 105 | } 106 | if ( read(KEYWORD, $keywordData, $length) != $length ) { 107 | die "Could not properly read keyword data\n"; 108 | } 109 | close KEYWORD; 110 | } 111 | 112 | foreach my $searchFile (<@files>) { 113 | my $searchFileLength = -s $searchFile; 114 | if ( $searchFileLength ) { 115 | my $searchData = chr(0x00) x $searchFileLength; 116 | open(SEARCH, $searchFile); 117 | binmode SEARCH; 118 | read(SEARCH,$searchData,$searchFileLength); 119 | close SEARCH; 120 | 121 | my $index = index($searchData,$keywordData); 122 | while ( $index >= 0 ) { 123 | printf("$searchFile @ \$%4.4X\n",$index,$searchFileLength); 124 | $index = index($searchData,$keywordData,$index+1); 125 | } 126 | } 127 | } 128 | 129 | 130 | sub Help { 131 | die ' 132 | scdbinsearch [options] 133 | scdbinsearch -keyword=<#> 134 | 135 | [description] 136 | Search for a binary keyword chunk in binary search files(s). 137 | 138 | [options] 139 | -offset=<#> byte offset in keyword file (default 0) 140 | -length=<#> byte length of keyword (default remainder of keyword file) 141 | -end=<#> byte end in keyword file 142 | -wordoffset=<#> word offset in keyword file 143 | -wordlength=<#> word length of keyword 144 | -wordend=<#> word end in keyword file 145 | -longoffset=<#> long (4 byte) offset in keyword file 146 | -longlength=<#> long (4 byte) length of keyword 147 | -longend=<#> long (4 byte) end of keyword 148 | -tileoffset=<#> tile (32 byte) offset in keyword file 149 | -tilelength=<#> tile (32 byte) length of keyword 150 | -tileend=<#> tile (32 byte) end of keyword 151 | -paloffset=<#> pal (32 byte) offset in keyword file 152 | -pallength=<#> pal (32 byte) length of keyword 153 | -palend=<#> pal (32 byte) end of keyword 154 | 155 | '; 156 | } 157 | -------------------------------------------------------------------------------- /scdpatchasm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2015 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | use strict; 21 | use warnings; 22 | 23 | if ( $#ARGV < 0 || $#ARGV > 1 ) { 24 | &Help(); 25 | } 26 | 27 | my $romFile0 = $ARGV[0]; 28 | my $romFile1 = $#ARGV < 1 ? $romFile0 : $ARGV[1]; 29 | 30 | my $verbosity = 2; 31 | 32 | my $romFile0Length = -s $romFile0; 33 | my $romFile0Data = ''; 34 | 35 | open( ROM, $romFile0 ) or die "Could not read file: $romFile0\n"; 36 | binmode ROM; 37 | read( ROM, $romFile0Data, $romFile0Length ); 38 | close ROM; 39 | 40 | my $romFile1Length = $romFile0Length; 41 | my $romFile1Data = $romFile0Data; 42 | 43 | my $patchAsmFooter = $romFile0Length-16; 44 | 45 | if ( $romFile1Length < 16 || 46 | substr($romFile1Data,$patchAsmFooter,8) ne 'PATCHASM' ) { 47 | print STDERR "No PATCHASM detected\n"; 48 | exit; 49 | } 50 | 51 | # loop in case more than 1 PATCHASM set of patches is in file 52 | while ( $patchAsmFooter != 0 ) { 53 | if ( $patchAsmFooter + 16 > $romFile1Length ) { 54 | die "Bad linked PATCHASM\n"; 55 | } 56 | 57 | if ( substr($romFile1Data,$patchAsmFooter,8) ne 'PATCHASM' ) { 58 | die "Bad linked PATCHASM\n"; 59 | } 60 | 61 | my $patchAsmInitialize = unpack("N",substr($romFile1Data,$patchAsmFooter+8,4)); 62 | if ( $patchAsmInitialize > $patchAsmFooter ) { 63 | die "Invalid PATCHASM initialize address\n"; 64 | } 65 | 66 | my $patchAsmLink = unpack("N",substr($romFile1Data,$patchAsmFooter+12,4)); 67 | 68 | my $patchAsmAddress = $patchAsmInitialize; 69 | 70 | while ($patchAsmAddress != $patchAsmFooter) { 71 | if ( substr($romFile1Data,$patchAsmAddress,8) eq 'PATCHASM' ) { 72 | # PATCHASM footer found, skip over 73 | $patchAsmAddress += 16; 74 | } else { 75 | my $patchAsmAddressNext = unpack("N",substr($romFile1Data,$patchAsmAddress,4)); 76 | my $patchAsmTargetLength = ( $patchAsmAddressNext - $patchAsmAddress - 8 ); 77 | if ( $patchAsmTargetLength < 0 ) { 78 | die "Invalid PATCHASM next address\n"; 79 | } 80 | my $patchAsmTargetAddress = unpack("N",substr($romFile1Data,$patchAsmAddress+4,4)); 81 | if ( $patchAsmTargetAddress != 0 ) { 82 | # regular entry 83 | if ( $patchAsmTargetAddress + $patchAsmTargetLength > $patchAsmInitialize ) { 84 | die "Invalid PATCHASM target address\n"; 85 | } 86 | my $patchAsmTargetData = substr($romFile1Data,$patchAsmAddress+8,$patchAsmTargetLength); 87 | substr($romFile1Data,$patchAsmTargetAddress,$patchAsmTargetLength) = $patchAsmTargetData; 88 | $patchAsmAddress = $patchAsmAddressNext; 89 | } else { 90 | die "Advanced format not architected or implemented\n"; 91 | } 92 | } 93 | } 94 | 95 | if ( $patchAsmFooter + 16 == $romFile1Length ) { 96 | $romFile1Length = $patchAsmInitialize; 97 | $romFile1Data = substr($romFile1Data,0,$romFile1Length); 98 | } 99 | 100 | $patchAsmFooter = $patchAsmLink; 101 | } 102 | 103 | open( ROM, '>'.$romFile1 ) or die "Could not read file: $romFile1\n"; 104 | binmode ROM; 105 | print ROM $romFile1Data; 106 | close ROM; 107 | 108 | print STDERR "PATCHASM applied\n"; 109 | 110 | 111 | sub Help { 112 | die ' 113 | scdpatchasm [binfileout] 114 | 115 | [description] 116 | Patch updates binary file using PATCHASM format. If binfileout is not 117 | specified updates binfile. 118 | 119 | [PATCHASM format] 120 | The patch data is located after the binary data of the source (typically). 121 | It consists of patch entries with a final patch footer. Patch footers 122 | in between patch entries will be skipped in case of multiple patches. 123 | 124 | [patch entry] 125 | dc.l 126 | dc.l 127 | 128 | 129 | [patch footer] 130 | dc.b \'PATCHASM\' 131 | dc.l 132 | dc.l 133 | 134 | 135 | All patch data at the end of the file will be removed. If a linking patch 136 | entry is in the middle of the data it will not be removed. 137 | 138 | This format was intended to allow hacking a ROM disassembly without 139 | modifying the disassembly, but allowing usage of the ROM disassembly labels 140 | and to use assembly to make the patch data (one known limit is that relative 141 | references require special rorg type code if truly needed). 142 | 143 | [PATCHASM example] 144 | include rom.asm 145 | PatchAsmInitialize: 146 | PatchAsm0000: 147 | dc.l PatchAsm0001 148 | dc.l Title_Local 149 | dc.b \'MY TOTALLY AWESOME ROM HACK \' 150 | PatchAsm0001: 151 | dc.l PatchAsm0002 152 | dc.l Title_Int 153 | dc.b \'MY TOTALLY AWESOME ROM HACK \' 154 | PatchAsm0002: 155 | PatchAsmFooter: 156 | dc.b \'PATCHASM\' 157 | dc.l PatchAsmInitialize 158 | dc.l 0 159 | 160 | '; 161 | } 162 | -------------------------------------------------------------------------------- /scdasm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | use strict; 21 | use warnings; 22 | 23 | # asmx-bgv only parameters: -pu1 -pa0 -u -n 24 | # kept seperated for now in case others are using different assemblers 25 | my $cmd68k = 'asmx -C 68000 -b 0 -e'; 26 | my $cmdz80 = 'asmx -C z80 -b 0 -e'; 27 | 28 | my $z80 = 0; 29 | my $verbosity = 2; 30 | my $options = ''; 31 | my $warnings = 1; 32 | 33 | my $asm = 'asmx'; 34 | 35 | my @args; 36 | foreach my $arg (@ARGV) { 37 | if ( $arg =~ m/^-(68k|68000)$/i ) { 38 | $z80 = 0; 39 | } elsif ( $arg =~ m/^-z80$/i ) { 40 | $z80 = 1; 41 | } elsif ( $arg =~ m/^-vasm$/i ) { 42 | $asm = 'vasm'; 43 | } elsif ( $arg =~ m/^-vasm_?unopt$/i ) { 44 | $asm = 'vasm_unopt'; 45 | } elsif ( $arg =~ m/^-asm68k_?wine$/i ) { 46 | $asm = 'asm68k_wine'; 47 | } elsif ( $arg =~ m/^-asm68k_?wine_?opt$/i ) { 48 | $asm = 'asm68k_wine_opt'; 49 | } elsif ( $arg =~ m/^-asmx$/i ) { 50 | $asm = 'asmx'; 51 | } elsif ( $arg =~ m/^-v=(\d+)$/i ) { 52 | $verbosity = $1; 53 | } elsif ( $arg =~ m/^-options=(.*)$/i ) { 54 | $options .= ' '.$1; 55 | } elsif ( $arg =~ m/^-nowarnings$/i ) { 56 | $warnings = 0; 57 | } else { 58 | push @args, $arg; 59 | } 60 | } 61 | 62 | if ( $warnings ) { 63 | $cmd68k .= " -w"; 64 | $cmdz80 .= " -w"; 65 | } 66 | 67 | if ( $asm eq 'asmx' ) { 68 | if ( $#args == 1 ) { 69 | my $asm = $args[0]; 70 | my $bin = $args[1]; 71 | $cmd68k .= " $options -o $bin -- $asm"; 72 | $cmdz80 .= " $options -o $bin -- $asm"; 73 | } elsif ( $#args == 2 ) { 74 | my $asm = $args[0]; 75 | my $bin = $args[1]; 76 | my $lst = $args[2]; 77 | $cmd68k .= " $options -l $lst -o $bin -- $asm"; 78 | $cmdz80 .= " $options -l $lst -o $bin -- $asm"; 79 | } else { 80 | &Help(); 81 | } 82 | } elsif ( $asm eq 'vasm' ) { 83 | if ( $#args == 1 ) { 84 | my $asm = $args[0]; 85 | my $bin = $args[1]; 86 | $cmd68k = "vasmm68k_mot -quiet -Fbin -m68000 $options -o $bin $asm"; 87 | $cmdz80 = "vasmz80_oldstyle -quiet -Fbin $options -o $bin $asm"; 88 | } elsif ( $#args == 2 ) { 89 | my $asm = $args[0]; 90 | my $bin = $args[1]; 91 | my $lst = $args[2]; 92 | $cmd68k = "vasmm68k_mot -quiet -Fbin -m68000 $options -o $bin $asm -L $lst"; 93 | $cmdz80 = "vasmz80_oldstyle -quiet -Fbin $options -o $bin $asm -L $lst"; 94 | } 95 | } elsif ( $asm eq 'vasm_unopt' ) { 96 | if ( $#args == 1 ) { 97 | my $asm = $args[0]; 98 | my $bin = $args[1]; 99 | $cmd68k = "vasmm68k_mot -quiet -Fbin -m68000 -no-opt $options -o $bin $asm"; 100 | $cmdz80 = "vasmz80_oldstyle -quiet -Fbin $options -o $bin $asm"; 101 | } elsif ( $#args == 2 ) { 102 | my $asm = $args[0]; 103 | my $bin = $args[1]; 104 | my $lst = $args[2]; 105 | $cmd68k = "vasmm68k_mot -quiet -Fbin -m68000 -no-opt $options -o $bin $asm -L $lst"; 106 | $cmdz80 = "vasmz80_oldstyle -quiet -Fbin $options -o $bin $asm -L $lst"; 107 | } 108 | } elsif ( $asm eq 'asm68k_wine' ) { 109 | if ( $#args == 1 ) { 110 | my $asm = $args[0]; 111 | my $bin = $args[1]; 112 | $cmd68k = "wine `which asm68k.exe` /q /k /p /o w+ $asm, $bin"; 113 | } elsif ( $#args == 2 ) { 114 | my $asm = $args[0]; 115 | my $bin = $args[1]; 116 | my $lst = $args[2]; 117 | $cmd68k = "wine `which asm68k.exe` /q /k /p /o w+ $asm, $bin, asm68k.sym, $lst"; 118 | } 119 | $cmdz80 = ""; 120 | } elsif ( $asm eq 'asm68k_wine_opt' ) { 121 | if ( $#args == 1 ) { 122 | my $asm = $args[0]; 123 | my $bin = $args[1]; 124 | $cmd68k = "wine `which asm68k.exe` /q /k /p /o w+ /o op+ /o os+ /o ow+ /o oz+ $asm, $bin"; 125 | } elsif ( $#args == 2 ) { 126 | my $asm = $args[0]; 127 | my $bin = $args[1]; 128 | my $lst = $args[2]; 129 | $cmd68k = "wine `which asm68k.exe` /q /k /p /o w+ /o op+ /o os+ /o ow+ /o oz+ $asm, $bin, asm68k.sym, $lst"; 130 | } 131 | $cmdz80 = ""; 132 | } 133 | 134 | my $cmd = $z80 ? $cmdz80 : $cmd68k; 135 | 136 | # only need to filter STDERR if low verbosity 137 | if ( $verbosity < 2 ) { 138 | # TODO not sure how portable 2>&1 is though... 139 | # TODO can be avoided by not setting verbosity 140 | $cmd .= ' 2>&1'; 141 | } 142 | 143 | if ( ! open( CMD, "$cmd |" ) ) { 144 | die "scdasm could not run command: $cmd\n"; 145 | } 146 | 147 | while ( my $line = ) { 148 | # remove empty lines 149 | # remove Pass 1 and Pass 2 lines 150 | # remove 0 Total Error(s) lines 151 | if ( $verbosity >= 2 || 152 | $line !~ m/^(\s*|\s*Pass\s*[12]\s*|\s*0+\s*Total\s*Error\(s\)\s*)$/ ) { 153 | print $line; 154 | } 155 | } 156 | 157 | close CMD; 158 | 159 | sub Help { 160 | die ' 161 | scdasm [options] [lstfile] 162 | 163 | [description] 164 | wrapper script for assembling 68k code 165 | 166 | [options] 167 | -68k specify 68k assembling (default) 168 | -z80 specify z80 assembling 169 | -v=<#> specify verbosity 170 | -options= options to send to assembler 171 | -nowarnings disable assembler warnings 172 | 173 | -vasm use vasm (vasmm68k_mot or vasmz80_oldstyle) 174 | -vasmunopt use vasm unopt (vasmm68k_mot or vasmz80_oldstyle) 175 | -asm68kwine use asm68k under wine 176 | 177 | '; 178 | } 179 | -------------------------------------------------------------------------------- /SCDTools/DisPick.pm: -------------------------------------------------------------------------------- 1 | ############################################################################### 2 | # Copyright (c) 2014 by bgvanbur 3 | # 4 | # This program is free software; you can redistribute it and/or modify it 5 | # under the terms of the GNU General Public License as published by the 6 | # Free Software Foundation; either version 2 of the License, or (at your 7 | # option) any later version. 8 | # 9 | # This program is distributed in the hope that it will be useful, but 10 | # WITHOUT ANY WARRANTY; without even the implied warranty of 11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | # GNU General Public License for more details. 13 | # 14 | # You should have received a copy of the GNU General Public License along 15 | # with this program; if not, write to the Free Software Foundation, Inc., 16 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | ############################################################################### 18 | # Disassemble Support (for scddisassemble) 19 | ############################################################################### 20 | 21 | package SCDTools::DisPick; 22 | use strict; 23 | use warnings; 24 | 25 | require Exporter; 26 | our @ISA = qw(Exporter); 27 | our @EXPORT = qw( 28 | CPU_68K 29 | CPU_Z80 30 | 31 | ASM_ASL 32 | ASM_ASMX 33 | ASM_GAS 34 | ASM_GAS_MRI 35 | ASM_PASMO 36 | ASM_SJASM 37 | ASM_SNASM68K 38 | ASM_TASM 39 | ASM_VASM 40 | ASM_Z80ASM 41 | 42 | PickReset 43 | PickCPU 44 | PickAssembler 45 | PickComplete 46 | 47 | GetCPU 48 | GetAssembler 49 | 50 | Disassemble 51 | Disassembly_NiceCheck 52 | Disassembly_MnemCheck 53 | ); 54 | 55 | 56 | use constant CPU_MASK => 0x000000FF; 57 | use constant ASM_MASK => 0x00FFFF00; 58 | 59 | use constant CPU_68K => 0x00000001; 60 | use constant CPU_Z80 => 0x00000002; 61 | 62 | # does both 68k and z80 63 | use constant ASM_ASL => 0x00000100; 64 | use constant ASM_ASMX => 0x00000200; 65 | use constant ASM_VASM => 0x00000400; 66 | 67 | # special case does both 68k and z80 68 | use constant ASM_GAS => 0x00001000; 69 | 70 | # does just 68k 71 | use constant ASM_SNASM68K => 0x00010000; 72 | use constant ASM_GAS_MRI => 0x00020000; 73 | 74 | # does just z80 75 | use constant ASM_PASMO => 0x00100000; 76 | use constant ASM_SJASM => 0x00200000; 77 | use constant ASM_TASM => 0x00400000; 78 | use constant ASM_Z80ASM => 0x00800000; 79 | 80 | use constant ASM_MASK_68K => 0x000FFF00; 81 | use constant ASM_MASK_Z80 => 0x00F0FF00; 82 | 83 | my $target = 0; 84 | 85 | 86 | 87 | use SCDTools::DisCommon; 88 | use SCDTools::DisFormat; 89 | 90 | 91 | sub PickReset { 92 | $target = 0; 93 | } 94 | 95 | sub PickCPU { 96 | $target = $target | ( $_[0] & CPU_MASK ); 97 | } 98 | 99 | sub PickAssembler { 100 | $target = $target | ( $_[0] & ASM_MASK ); 101 | } 102 | 103 | sub GetCPU { 104 | return ( $target & CPU_MASK ); 105 | } 106 | 107 | sub GetAssembler { 108 | return ( $target & ASM_MASK ); 109 | } 110 | 111 | sub PickComplete { 112 | my $cpu = &GetCPU(); 113 | my $asm = &GetAssembler(); 114 | if ( $cpu == 0 ) { 115 | $cpu = CPU_68K; 116 | } 117 | if ( $cpu == CPU_68K ) { 118 | if ( $asm == 0 ) { 119 | # not GAS by default 120 | $asm = ASM_SNASM68K | ASM_ASMX | ASM_ASL | ASM_VASM | ASM_GAS_MRI; 121 | &PickAssembler($asm); 122 | } 123 | no warnings 'redefine'; 124 | *Disassemble = \&SCDTools::Dis68K::Disassemble68K; 125 | *Disassembly_NiceCheck = \&SCDTools::Dis68K::Disassemble68K_NiceCheck; 126 | *Disassembly_MnemCheck = \&SCDTools::Dis68K::Disassemble68K_MnemCheck; 127 | &SetAlwaysOrg(0); 128 | &SetDataToBigEndian(); 129 | &SetDataWidthToWord(); 130 | &ChangeImmediateFormat('$',''); 131 | &SetAddressWidth(24); 132 | &ChangeComment(';;'); 133 | &ChangeDataDirectiveKeywords('DC.B','DC.W','DC.L'); 134 | &ChangeDataStringDirectiveKeyword('DC.B'); 135 | &SetDirectiveStringOnlyIfAllPrintable(0); 136 | &ChangeEquUsesColon(1); 137 | &ChangeEquUsesLabel(1); 138 | if ( $target & ASM_GAS ) { 139 | &ChangeImmediateFormat('0x',''); 140 | &ChangeComment('|'); 141 | &ChangeDataDirectiveKeywords('.byte','.word','.long'); 142 | &ChangeDataStringDirectiveKeyword('.ascii'); 143 | &SetDirectiveStringOnlyIfAllPrintable(1); 144 | &SetCaseReg(0); 145 | &ChangeOrgDirectiveKeyword('.org'); 146 | &ChangeEquDirectiveKeyword('.equ'); 147 | &ChangeEquUsesLabel(0); 148 | } 149 | &SCDTools::Dis68K::Disassemble68K_Setup(); 150 | } elsif ( $cpu == CPU_Z80 ) { 151 | if ( $asm == 0 ) { 152 | # not TASM by default 153 | $asm = ASM_ASL | ASM_ASMX | ASM_GAS | ASM_PASMO | ASM_SJASM | ASM_VASM | ASM_Z80ASM; 154 | &PickAssembler($asm); 155 | } 156 | no warnings 'redefine'; 157 | *Disassemble = \&SCDTools::DisZ80::DisassembleZ80; 158 | *Disassembly_NiceCheck = \&SCDTools::DisZ80::DisassembleZ80_NiceCheck; 159 | *Disassembly_MnemCheck = \&SCDTools::DisZ80::DisassembleZ80_MnemCheck; 160 | &SetAlwaysOrg(1); 161 | &SetDataToLittleEndian(); 162 | &SetDataWidthToByte(); 163 | &ChangeImmediateFormat('0','H'); 164 | &SetAddressWidth(16); 165 | &ChangeComment(';;'); 166 | &ChangeDataDirectiveKeywords('DB','DW','?'); 167 | &ChangeDataStringDirectiveKeyword('DC.B'); 168 | &SetDirectiveStringOnlyIfAllPrintable(0); 169 | &ChangeEquUsesColon(1); 170 | &ChangeEquUsesLabel(1); 171 | if ( $target & ASM_TASM ) { 172 | &SetAlwaysOrg(0); 173 | &ChangeDataDirectiveKeywords('.DB','.DW','?'); 174 | } 175 | # VASM May 2, 2014 1.6 build does not need this 176 | # if ( $target & ASM_VASM ) { 177 | # &ChangeImmediateFormat('0x',''); 178 | # &ChangeEquUsesColon(0); 179 | # } 180 | &SCDTools::DisZ80::DisassembleZ80_Setup(); 181 | } else { 182 | die "Too many CPUs specified\n"; 183 | } 184 | } 185 | 186 | 187 | # Disassemble 188 | # pass in [0] address of instruction 189 | # returns [0] DIS_PRBM to note any disassembly problems 190 | # returns [1] DATA_USAGE_NEXT information 191 | # returns [2] string representation of instruction 192 | # returns [3] width of instruction in bytes 193 | 194 | # TODO document other instruction common 195 | 196 | 1; 197 | -------------------------------------------------------------------------------- /scdwrite: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | # burn a sega cd from a backup 20 | # requires all files for only one sega cd are in the PWD 21 | # * supports bin/cue 22 | # * supports iso/mp3 23 | # * supports iso/wav 24 | ############################################################################### 25 | 26 | use strict; 27 | use warnings; 28 | 29 | my $swap = 0; 30 | my $prefix = ''; 31 | 32 | foreach my $arg (@ARGV) { 33 | if ( $arg =~ /^-swap$/i ) { 34 | $swap = 1; 35 | } elsif ( $arg =~ /^-prefix=(.*)$/i ) { 36 | $prefix = $1; 37 | } else { 38 | &Help(); 39 | } 40 | } 41 | 42 | ############################################################################### 43 | # configuration variables 44 | ############################################################################### 45 | 46 | # useWav 0 (mp3) 1 (wav) 47 | 48 | my $useWav = 1; 49 | 50 | # useToc 0 (cue) 1 (toc) 51 | 52 | my $useToc = 0; 53 | 54 | my $deleteCreatedFiles = 0; 55 | my $requireAudioFilesForIso = 0; 56 | 57 | ############################################################################### 58 | # global variables 59 | ############################################################################### 60 | 61 | # toc/cue file to use for burning 62 | 63 | my $guide; 64 | 65 | # list of large files generated by this script to delete when done 66 | 67 | my @filesToDelete; 68 | 69 | ############################################################################### 70 | # actual execution 71 | ############################################################################### 72 | 73 | # check for bin/cue format 74 | 75 | my @bins = (<${prefix}*.bin>,<${prefix}*.BIN>); 76 | my @cues = (<${prefix}*.cue>,<${prefix}*.CUE>); 77 | 78 | # determine format (bin/cue or iso/mp3 or iso/wav) 79 | 80 | if ( $#bins == 0 && $#cues == 0 ) { 81 | 82 | # bin/cue format 83 | 84 | $guide = $cues[0]; 85 | 86 | } else { 87 | 88 | # look for iso/mp3 or iso/wav format 89 | 90 | # get iso name 91 | 92 | my @isos = (<${prefix}*.iso>,<${prefix}*.ISO>); 93 | 94 | if ( $#isos != 0 ) { 95 | die "Only support one iso in PWD"; 96 | } 97 | 98 | my $iso = $isos[0]; 99 | 100 | # convert mp3 files to wav files 101 | 102 | if ( $useWav ) { 103 | foreach my $mp3 ((<${prefix}*.mp3>,<${prefix}*.MP3>)) { 104 | my $out = $mp3; 105 | $out =~ s/\.mp3$/.wav/; 106 | if ( ! -e $out ) { 107 | #system("mpg123 --wav \"$out\" \"$mp3\""); 108 | system("ffmpeg -i \"$mp3\" -vn -acodec pcm_s16le -ar 44100 -ac 2 -f wav \"$out\""); 109 | if ( $deleteCreatedFiles ) { 110 | push @filesToDelete, $out; 111 | } 112 | } 113 | } 114 | } 115 | 116 | # collect audio (mp3/wave) file information 117 | 118 | my @audios; 119 | my $audioType; 120 | 121 | if ( $useWav ) { 122 | @audios = sort (<${prefix}*.wav>,<${prefix}*.WAV>); 123 | $audioType = 'WAVE'; 124 | } else { 125 | @audios = sort (<${prefix}*.mp3>,<${prefix}*.MP3>); 126 | $audioType = 'MP3'; 127 | } 128 | 129 | if ( $requireAudioFilesForIso && $#audios < 0 ) { 130 | die "No audio files found\n"; 131 | } 132 | 133 | # determine toc and cue filenames 134 | 135 | $guide = $iso; 136 | if ( $useToc ) { 137 | $guide =~ s/\.iso$/.toc/; 138 | $guide =~ s/\.ISO$/.TOC/; 139 | } else { 140 | $guide =~ s/\.iso$/.cue/; 141 | $guide =~ s/\.ISO$/.CUE/; 142 | } 143 | 144 | # print toc/cue entry for data track 145 | 146 | my $guideText = ''; 147 | 148 | if ( $useToc ) { 149 | $guideText .= "CD_ROM\n"; 150 | $guideText .= "TRACK MODE1\n"; 151 | $guideText .= "DATAFILE \"$iso\"\n"; 152 | } else { 153 | $guideText .= "FILE \"$iso\" BINARY\n"; 154 | $guideText .= " TRACK 01 MODE1/2048\n"; 155 | $guideText .= " INDEX 01 00:00:00\n"; 156 | } 157 | 158 | # print toc/cue entries for audio tracks 159 | # when track is 2, need to add a post-gap to track 1 and pre-gap to track 2 160 | 161 | my $track = 2; 162 | 163 | foreach my $audio (@audios) { 164 | if ( $useToc ) { 165 | if ( $track == 2 ) { 166 | $guideText .= "ZERO 00:02:00 // post-gap\n"; 167 | $guideText .= "\n"; 168 | } 169 | $guideText .= "TRACK AUDIO\n"; 170 | if ( $track == 2 ) { 171 | $guideText .= "SILENCE 00:02:00 // pre-gap\n"; 172 | $guideText .= "START\n"; 173 | } 174 | $guideText .= "FILE \"$audio\" 0\n"; 175 | $guideText .= "\n"; 176 | } else { 177 | my $trackText = sprintf("%2.2d",$track); 178 | if ( $track == 2 ) { 179 | $guideText .= " POSTGAP 00:02:00\n"; 180 | } 181 | $guideText .= "FILE \"$audio\" $audioType\n"; 182 | $guideText .= " TRACK $trackText AUDIO\n"; 183 | if ( $track == 2 ) { 184 | $guideText .= " PREGAP 00:02:00\n"; 185 | } 186 | $guideText .= " INDEX 01 00:00:00\n"; 187 | } 188 | $track++; 189 | } 190 | 191 | # now write toc/cue file 192 | 193 | open( GUIDE, ">$guide" ) or die "Cannot write file: $guide\n"; 194 | print GUIDE $guideText; 195 | close GUIDE; 196 | 197 | print $guideText; 198 | } 199 | 200 | # now burn the sega cd (guide already set to toc/cue accordingly to format) 201 | 202 | my $options = ''; 203 | if ( $swap ) { 204 | $options = ' --swap'; 205 | } 206 | my $cmd = "cdrdao write$options --speed 1 --driver generic-mmc \"$guide\""; 207 | 208 | # burn at 1x 209 | print "Running: $cmd\n"; 210 | system($cmd); 211 | 212 | # delete any generated files we made 213 | # we keep the cue/toc since its a small file anyways 214 | 215 | if ( $deleteCreatedFiles ) { 216 | foreach my $file (@filesToDelete) { 217 | system("rm \"$file\""); 218 | } 219 | } 220 | 221 | sub Help { 222 | die ' 223 | scdwrite [options] 224 | 225 | [description] 226 | Write a CD-R with the data for Sega CD. 227 | 228 | [options] 229 | 230 | -swap passes --swap to cdrdao 231 | 232 | '; 233 | } 234 | -------------------------------------------------------------------------------- /scdbincuecheck: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2014 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | use strict; 21 | use warnings; 22 | 23 | if ( $#ARGV < 0 ) { 24 | &Help(); 25 | } 26 | 27 | foreach my $cue (@ARGV) { 28 | &CheckCue($cue); 29 | } 30 | 31 | 32 | 33 | sub CheckCue { 34 | my ($cue) = @_; 35 | 36 | if ( ! open(CUE, $cue) ) { 37 | die "Could not open cue: $cue\n"; 38 | } 39 | 40 | my $file = ''; 41 | my $fileMode = ''; 42 | my $track = -1; 43 | my $trackMin = -1; 44 | my $trackMax = -1; 45 | my @trackdata; 46 | 47 | while ( my $cueLine = ) { 48 | chomp $cueLine; 49 | my $bad = 0; 50 | if ( $cueLine =~ /^\s*FILE\s+\"([^\"]+)\"\s*(BINARY|WAVE)\s*$/ ) { 51 | $file = $1; 52 | $fileMode = $2; 53 | } elsif ( $cueLine =~ /^\s*TRACK\s+(\d+)\s+(MODE1\/2048|MODE1\/2352|AUDIO)\s*$/ ) { 54 | my $track = $1; 55 | my $mode = $2; 56 | $trackdata[$track]{'file'} = $file; 57 | $trackdata[$track]{'filemode'} = $fileMode; 58 | $trackdata[$track]{'mode'} = $mode; 59 | if ( $trackMin < 0 || $track < $trackMin ) { 60 | $trackMin = $track; 61 | } 62 | if ( $trackMax < 0 || $track > $trackMax ) { 63 | $trackMax = $track; 64 | } 65 | } elsif ( $cueLine =~ /^\s*INDEX\s+(\d+)\s+(\d+):(\d+):(\d+)\s*$/ ) { 66 | my $index = $1; 67 | my $mm = $2; 68 | my $ss = $3; 69 | my $ff = $3; 70 | my $sector = $ff + 75 * ( $ss + 60* $mm ); 71 | if ( $index == 0 ) { 72 | $trackdata[$track]{'index0sector'} = $sector; 73 | } elsif ( $index == 1 ) { 74 | $trackdata[$track]{'index1sector'} = $sector; 75 | } else { 76 | $bad = 1; 77 | } 78 | } elsif ( $cueLine =~ /^\s*PREGAP\s/ ) { 79 | # ignore for now 80 | } elsif ( $cueLine =~ /^\s*POSTGAP\s/ ) { 81 | # ignore for now 82 | } elsif ( $cueLine =~ /^\s*CATALOG\s/ ) { 83 | # ignore for now 84 | } elsif ( $cueLine !~ /^\s*\/\// && 85 | $cueLine !~ /^\s*$/ ) { 86 | $bad = 1; 87 | } 88 | if ( $bad ) { 89 | print "Did not parse line: $cueLine\n"; 90 | } 91 | } 92 | 93 | use bigint; 94 | 95 | foreach my $track ($trackMin..$trackMax) { 96 | if ( exists $trackdata[$track] && 97 | exists $trackdata[$track]{'file'} && 98 | exists $trackdata[$track]{'filemode'} && 99 | exists $trackdata[$track]{'mode'} ) { 100 | my $sectorSize = 2352; 101 | my $sectorStart = 0; 102 | if ( exists $trackdata[$track]{'index1sector'} ) { 103 | $sectorStart = $trackdata[$track]{'index1sector'}; 104 | } elsif ( exists $trackdata[$track]{'index0sector'} ) { 105 | $sectorStart = $trackdata[$track]{'index0sector'}; 106 | } 107 | my $sectorEnd = -1; 108 | if ( exists $trackdata[$track+1] && 109 | exists $trackdata[$track+1]{'file'} && 110 | $trackdata[$track]{'file'} eq $trackdata[$track+1]{'file'} ) { 111 | if ( exists $trackdata[$track+1]{'index0sector'} ) { 112 | $sectorEnd = $trackdata[$track+1]{'index0sector'}; 113 | } elsif ( exists $trackdata[$track+1]{'index1sector'} ) { 114 | $sectorEnd = $trackdata[$track+1]{'index1sector'}; 115 | } 116 | } 117 | my $fileLength = -s $trackdata[$track]{'file'}; 118 | my $start = $sectorSize * $sectorStart; 119 | my $end = $sectorSize * $sectorEnd; 120 | if ( $sectorEnd < 0 ) { 121 | $end = $fileLength; 122 | } 123 | if ( $start >= $end ) { 124 | print STDERR "start/end of track looks incorrect\n"; 125 | } 126 | if ( $end > $fileLength ) { 127 | print STDERR "end exceeds file length\n"; 128 | } 129 | my $length = $end-$start; 130 | if ( $trackdata[$track]{'filemode'} eq 'BINARY' && 131 | $trackdata[$track]{'mode'} eq 'AUDIO' ) { 132 | #print "TRACK $track\n"; 133 | if ( ! open(FILE, $trackdata[$track]{'file'}) ) { 134 | print STDERR "Could not open file: $file\n"; 135 | } else { 136 | binmode FILE; 137 | my $trackData = ''; 138 | if ( $start > 0 ) { 139 | seek(FILE,$start,0); 140 | } 141 | read(FILE,$trackData,$length); 142 | close FILE; 143 | my $sumBig = 0; 144 | my $sumLittle = 0; 145 | my $samples = 0; 146 | # 16 bit signed data, alternates channels 147 | # do one sector out of every 10 seconds (1 out of every 750 sectors) 148 | for ( my $sector = 0; $sector < $length-$sectorSize; $sector += 10*75*$sectorSize ) { 149 | for ( my $channel = 0; $channel < 2; $channel += 2 ) { 150 | my $lastBig = 0; 151 | my $lastLittle = 0; 152 | for ( my $i = $channel; $i < 2352; $i += 4 ) { 153 | my $this0 = ord(substr($trackData,$i+$channel+$sector,1)); 154 | my $this1 = ord(substr($trackData,$i+$channel+$sector+1,1)); 155 | 156 | my $thisBig = $this0*256+$this1; 157 | if ( $thisBig & 0x8000 ) { 158 | $thisBig = ( ~ ( $thisBig & 0x7FFF ) + 1 ); 159 | } 160 | 161 | my $thisLittle = $this1*256+$this0; 162 | if ( $thisLittle & 0x8000 ) { 163 | $thisLittle = ( ~ ( $thisLittle & 0x7FFF ) + 1 ); 164 | } 165 | 166 | #printf("%2.2X %2.2X %8.8X %8.8X\n",$this0,$this1,$thisBig,$thisLittle); 167 | if ( $i >= 4 ) { 168 | my $diffBig = $thisBig-$lastBig; 169 | if ( $diffBig < 0 ) { 170 | $diffBig = 0 - $diffBig; 171 | } 172 | 173 | my $diffLittle = $thisLittle-$lastLittle; 174 | if ( $diffLittle < 0 ) { 175 | $diffLittle = 0 - $diffLittle; 176 | } 177 | 178 | #printf(" %8.8X %8.8X\n",$diffBig,$diffLittle); 179 | $sumBig += $diffBig; 180 | $sumLittle += $diffLittle; 181 | $samples++; 182 | } 183 | 184 | $lastBig = $thisBig; 185 | $lastLittle = $thisLittle; 186 | } 187 | } 188 | } 189 | my $avgBig = $sumBig / $samples; 190 | my $avgLittle = $sumLittle / $samples; 191 | if ( 0 ) { 192 | print "Track $track samples $samples\n"; 193 | print "Track $track sumBig $sumBig\n"; 194 | print "Track $track sumLittle $sumLittle\n"; 195 | print "Track $track avgBig $avgBig\n"; 196 | print "Track $track avgLittle $avgLittle\n"; 197 | } 198 | if ( $avgBig > 0x2000 && $avgBig > 4 * $avgLittle ) { 199 | print "Track $track audio appears to be little endian (suggest cdrdao --swap and scdwrite -swap)\n"; 200 | } elsif ( $avgLittle > 0x2000 && $avgLittle > 4 * $avgBig ) { 201 | print "Track $track audio appears to be big endian (cdrdao with no --swap and scdwrite with no -swap)\n"; 202 | } else { 203 | print "Track $track audio does not clearly indicate audio endianess (big average $avgBig vs little average $avgLittle)\n"; 204 | } 205 | } 206 | } 207 | } 208 | } 209 | } 210 | 211 | 212 | sub Help { 213 | die ' 214 | scdbincuecheck [cuefiles] 215 | 216 | [description] 217 | Checks a cue file for stuff. 218 | Currently only attempts to determine endianess of raw audio data. 219 | 220 | '; 221 | } 222 | -------------------------------------------------------------------------------- /scdwav2pcm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | use strict; 21 | use warnings; 22 | 23 | if ( $#ARGV < 0 ) { 24 | &Help(); 25 | } 26 | 27 | my $channel = 0; 28 | my $endPCMChars = 2; 29 | my $midpointIsPositive = 0; 30 | my $unsigned = 0; 31 | my @files; 32 | 33 | # parse args 34 | foreach my $arg (@ARGV) { 35 | if ( $arg =~ /^-channel=(\d+)$/i ) { 36 | $channel = $1; 37 | } elsif ( $arg =~ /^-endpcmchars=(\d+)$/i ) { 38 | $endPCMChars = $1; 39 | } elsif ( $arg =~ /^-midpointispositive$/i ) { 40 | $midpointIsPositive = 1; 41 | } elsif ( $arg =~ /^-unsigned$/i ) { 42 | $unsigned = 1; 43 | } else { 44 | push @files, $arg; 45 | } 46 | } 47 | 48 | if ( $#files != 1 ) { 49 | &Help(); 50 | } 51 | 52 | my $waveFile = $files[0]; 53 | my $pcmFile = $files[1]; 54 | 55 | my $waveFileSize = -s $waveFile; 56 | 57 | if ( ! open( WAVE, '<'.$waveFile ) ) { 58 | print STDERR "Could not open $waveFile\n"; 59 | exit 1; 60 | } 61 | binmode WAVE; 62 | 63 | if ( ! open( PCM, '>'.$pcmFile ) ) { 64 | print STDERR "Could not open $pcmFile\n"; 65 | exit 1; 66 | } 67 | binmode PCM; 68 | 69 | # if empty wave file then create empty pcm file and exit 70 | if ( $waveFileSize == 0 ) { 71 | close WAVE; 72 | close PCM; 73 | exit; 74 | } 75 | 76 | my $riffID = ''; 77 | if ( read(WAVE,$riffID,4) != 4 ) { 78 | print STDERR "Could not read WAVE\n"; 79 | exit 1; 80 | } 81 | if ( $riffID ne 'RIFF' ) { 82 | print STDERR "WAVE missing RIFF header\n"; 83 | exit 1; 84 | } 85 | 86 | my $riffLength = ''; 87 | if ( read(WAVE,$riffLength,4) != 4 ) { 88 | print STDERR "Could not read WAVE\n"; 89 | exit 1; 90 | } 91 | $riffLength = unpack("V",$riffLength); 92 | 93 | my $riffType = ''; 94 | if ( read(WAVE,$riffType,4) != 4 ) { 95 | print STDERR "Could not read WAVE\n"; 96 | exit 1; 97 | } 98 | if ( $riffType ne 'WAVE' ) { 99 | print STDERR "WAVE missing WAVE RIFF type\n"; 100 | exit 1; 101 | } 102 | 103 | my $chunkType = ''; 104 | my $chunkLength = 0; 105 | while (1) { 106 | my $chunkType = ''; 107 | if ( read(WAVE,$chunkType,4) != 4 ) { 108 | print STDERR "Could not read WAVE\n"; 109 | exit 1; 110 | } 111 | if ( read(WAVE,$chunkLength,4) != 4 ) { 112 | print STDERR "Could not read WAVE\n"; 113 | exit 1; 114 | } 115 | $chunkLength = unpack("V",$chunkLength); 116 | if ( $chunkType eq 'fmt ') { 117 | last; 118 | } 119 | seek(WAVE,$chunkLength,1); 120 | } 121 | 122 | my $fmtCompressionCode = ''; 123 | if ( read(WAVE,$fmtCompressionCode,2) != 2 ) { 124 | print STDERR "Could not read WAVE\n"; 125 | exit 1; 126 | } 127 | $fmtCompressionCode = unpack("v",$fmtCompressionCode); 128 | if ( $fmtCompressionCode != 1 ) { 129 | print STDERR "Only support PCM data in WAVE files\n"; 130 | exit 1; 131 | } 132 | 133 | my $fmtNumberOfChannels = ''; 134 | if ( read(WAVE,$fmtNumberOfChannels,2) != 2 ) { 135 | print STDERR "Could not read WAVE\n"; 136 | exit 1; 137 | } 138 | $fmtNumberOfChannels = unpack("v",$fmtNumberOfChannels); 139 | if ( $channel >= $fmtNumberOfChannels ) { 140 | print STDERR "Cannot request channel $channel when wave only has $fmtNumberOfChannels channels\n"; 141 | exit 1; 142 | } 143 | 144 | my $fmtSampleRate = ''; 145 | if ( read(WAVE,$fmtSampleRate,4) != 4 ) { 146 | print STDERR "Could not read WAVE\n"; 147 | exit 1; 148 | } 149 | $fmtSampleRate = unpack("V",$fmtSampleRate); 150 | 151 | my $fmtAverageBytesPerSecond = ''; 152 | if ( read(WAVE,$fmtAverageBytesPerSecond,4) != 4 ) { 153 | print STDERR "Could not read WAVE\n"; 154 | exit 1; 155 | } 156 | $fmtAverageBytesPerSecond = unpack("V",$fmtAverageBytesPerSecond); 157 | 158 | my $fmtBlockAlign = ''; 159 | if ( read(WAVE,$fmtBlockAlign,2) != 2 ) { 160 | print STDERR "Could not read WAVE\n"; 161 | exit 1; 162 | } 163 | $fmtBlockAlign = unpack("v",$fmtBlockAlign); 164 | 165 | my $fmtBitsPerSample = ''; 166 | if ( read(WAVE,$fmtBitsPerSample,2) != 2 ) { 167 | print STDERR "Could not read WAVE\n"; 168 | exit 1; 169 | } 170 | $fmtBitsPerSample = unpack("v",$fmtBitsPerSample); 171 | if ( $fmtBitsPerSample != 8 ) { 172 | print STDERR "Only support 8-bit PCM sample data\n"; 173 | exit 1; 174 | } 175 | 176 | seek(WAVE,$chunkLength-16,1); 177 | 178 | #print "$fmtCompressionCode $fmtNumberOfChannels $fmtSampleRate $fmtAverageBytesPerSecond $fmtBlockAlign $fmtBitsPerSample\n"; 179 | 180 | while (1) { 181 | my $chunkType = ''; 182 | if ( read(WAVE,$chunkType,4) != 4 ) { 183 | print STDERR "Could not read WAVE\n"; 184 | exit 1; 185 | } 186 | if ( read(WAVE,$chunkLength,4) != 4 ) { 187 | print STDERR "Could not read WAVE\n"; 188 | exit 1; 189 | } 190 | $chunkLength = unpack("V",$chunkLength); 191 | if ( $chunkType eq 'data') { 192 | last; 193 | } 194 | seek(WAVE,$chunkLength,1); 195 | } 196 | 197 | my $data = ''; 198 | if ( read(WAVE,$data,$chunkLength) != $chunkLength ) { 199 | print STDERR "Could not read WAVE\n"; 200 | exit 1; 201 | } 202 | 203 | close WAVE; 204 | 205 | my $pcmData = ''; 206 | my $maxAmp = 0; 207 | for ( my $i = $channel; $i < $chunkLength; $i += $fmtNumberOfChannels ) { 208 | my $valueWave = ord(substr($data,$i,1)); 209 | my $value; 210 | my $amp = 0; 211 | if ( $unsigned ) { 212 | $value = $valueWave; 213 | } else { 214 | if ( $valueWave == 0x80 ) { 215 | if ( $midpointIsPositive ) { 216 | $value = 0x00; 217 | } else { 218 | $value = 0x80; 219 | } 220 | } elsif ( $valueWave >= 0x80 ) { 221 | $amp = $valueWave - 0x80; 222 | $value = 0x00 | $amp; 223 | } else { 224 | $amp = 0x80 - $valueWave; 225 | $value = 0x80 | $amp; 226 | } 227 | if ( $amp > $maxAmp ) { 228 | $maxAmp = $amp; 229 | } 230 | if ( $value == 0xFF ) { 231 | print STDERR "truncating waveform\n"; 232 | $value = 0xFE; 233 | } 234 | } 235 | $pcmData .= chr($value); 236 | } 237 | 238 | $pcmData .= ( chr(0xFF) x $endPCMChars ); 239 | 240 | print PCM $pcmData; 241 | close PCM; 242 | 243 | if ( ! $unsigned ) { 244 | my $pcmFD = int(0.5+$fmtSampleRate/(12500000/384)*0x800); 245 | print "Wave sample rate corresponds to a Sega CD PCM FD register value of ".sprintf("0x%4.4X",$pcmFD)."\n"; 246 | print "Wave data had a max 8 bit amplitude of ".$maxAmp." (highest is 127)\n"; 247 | } 248 | 249 | 250 | 251 | sub Help { 252 | die ' 253 | scdwav2pcm [options] 254 | 255 | [description] 256 | Converts a wav file to an 8 bit signed magnitude mono Sega CD PCM data file. 257 | 258 | [options] 259 | -channel=<#> the channel index to extract (defaults to 0) 260 | -endpcmchars=<#> the number of 0xFF character to append to PCM data 261 | (defaults to 2) 262 | -midpointispositive use the PCM midpoint as 0x00 (defaults to 0x80) 263 | -unsigned PCM data is unsigned (useful for YM2612 PCM) 264 | 265 | [limitations] 266 | Currently only handles 8-bit PCM wav files. 267 | 268 | '; 269 | } 270 | -------------------------------------------------------------------------------- /scdbrm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2014 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | use strict; 21 | use warnings; 22 | 23 | my $blockSize = 0x40; 24 | my $bramSize = 0x2000; 25 | 26 | if ( $#ARGV < 0 ) { 27 | &Help(); 28 | } 29 | 30 | my $prefix = ''; 31 | 32 | my $tableLine = "+----------+-------------+----+-------+------+\n"; 33 | my $tableHead = "| DRIVE | FILENAME | DP | INDEX | SIZE |\n"; 34 | my $tableStarted = 0; 35 | 36 | foreach my $fileIn (@ARGV) { 37 | my $fileInData = ''; 38 | my $fileInLength = -s $fileIn; 39 | 40 | $prefix = $fileIn; 41 | $prefix =~ s/\.[^\.]+$//; 42 | $prefix =~ s/^[^[\\\/]*[\\\/]//g; 43 | $prefix .= '_'; 44 | 45 | my $fileOut = 'out.bin'; 46 | my $fileOutData = ''; 47 | 48 | open(FILEIN, '<'.$fileIn); 49 | binmode FILEIN; 50 | read(FILEIN,$fileInData,$fileInLength); 51 | close FILEIN; 52 | 53 | my $out = ''; 54 | my $internal = ''; 55 | my $cart = ''; 56 | if ( $fileIn =~ /\.crm/i ) { 57 | # RAM cartridge 58 | $cart = &BRAMDecodeDirectory('CART ',$fileInData); 59 | } else { 60 | # internal RAM 61 | if ( $fileInLength >= $bramSize ) { 62 | my $bramData = substr($fileInData,0,$bramSize); 63 | $internal = &BRAMDecodeDirectory('INTERNAL',$bramData); 64 | } 65 | 66 | # optional RAM cartridge 67 | if ( $fileInLength > $bramSize ) { 68 | my $cartData = substr($fileInData,$bramSize,$fileInLength-$bramSize); 69 | 70 | $cart = &BRAMDecodeDirectory('CART ',$cartData); 71 | } 72 | } 73 | 74 | if ( $internal ne '' ) { 75 | if ( ! $tableStarted ) { 76 | $out .= $tableLine.$tableHead.$tableLine; 77 | $tableStarted = 1; 78 | } 79 | $out .= $internal.$tableLine; 80 | } 81 | if ( $cart ne '' ) { 82 | if ( ! $tableStarted ) { 83 | $out .= $tableLine.$tableHead.$tableLine; 84 | $tableStarted = 1; 85 | } 86 | $out .= $cart.$tableLine; 87 | } 88 | 89 | print $out; 90 | 91 | for ( my $index = 0; $index + $blockSize <= $fileInLength; $index += $blockSize ) { 92 | my $block = substr($fileInData,$index,$blockSize); 93 | my $decoded = &BRAMDecodeDataProtectedBlock($block); 94 | $fileOutData .= $decoded; 95 | } 96 | 97 | open(FILEOUT, '>'.$fileOut); 98 | binmode FILEOUT; 99 | print FILEOUT $fileOutData; 100 | close FILEOUT; 101 | } 102 | 103 | 104 | sub BRAMDecodeDirectory { 105 | my ($drive,$bramData) = @_; 106 | # TODO format check? 107 | my $bramDataLength = length($bramData); 108 | if ( $bramDataLength & 0x3F ) { 109 | print STDERR "Bad bram size\n"; 110 | return ''; 111 | } 112 | my $lastBlockIndex = $bramDataLength - $blockSize; 113 | if ( substr($bramData,$lastBlockIndex) =~ /^[\x00]+$/ ) { 114 | return sprintf("| %s | %s | | | |%s\n",$drive,' ',' (unformatted drive)'); 115 | } 116 | my $blocksFree = unpack("n",substr($bramData,$lastBlockIndex+0x10,2)); 117 | if ( $blocksFree != unpack("n",substr($bramData,$lastBlockIndex+0x12,2)) || 118 | $blocksFree != unpack("n",substr($bramData,$lastBlockIndex+0x14,2)) || 119 | $blocksFree != unpack("n",substr($bramData,$lastBlockIndex+0x16,2)) ) { 120 | print STDERR "Inconsistent blocks free value\n"; 121 | return ''; 122 | } 123 | my $filesUsed = unpack("n",substr($bramData,$lastBlockIndex+0x18,2)); 124 | if ( $filesUsed != unpack("n",substr($bramData,$lastBlockIndex+0x1A,2)) || 125 | $filesUsed != unpack("n",substr($bramData,$lastBlockIndex+0x1C,2)) || 126 | $filesUsed != unpack("n",substr($bramData,$lastBlockIndex+0x1E,2)) ) { 127 | print STDERR "Inconsistent files used value\n"; 128 | return ''; 129 | } 130 | if ( $blocksFree == 0 && $filesUsed == 0 ) { 131 | print STDERR "Zero files used and zero blocks free makes no sense\n"; 132 | return ''; 133 | } 134 | my $directoryIndex = $lastBlockIndex - $filesUsed * 0x20; 135 | if ( $directoryIndex < 0x40 + $filesUsed * 0x40 ) { 136 | print STDERR "Directory table too big"; 137 | return ''; 138 | } 139 | my $table = ''; 140 | if ( $filesUsed == 0 ) { 141 | $table .= sprintf("| %s | %s | | | |%s\n",$drive,' ',' (empty drive)'); 142 | } else { 143 | for ( my $i = $lastBlockIndex-0x20; $i >= $directoryIndex; $i -= 0x20 ) { 144 | my $block = substr($bramData,$i & 0xFFFFC0,$blockSize); 145 | my $decoded = &BRAMDecodeDataProtectedBlock($block); 146 | my $entry = substr($decoded,($i & 0x3F) >> 1,0x10); 147 | my $fileName = substr($entry,0,11); 148 | my $fileDatProt = ord(substr($entry,11,1)); 149 | my $fileBlockStart = unpack("n",substr($entry,12,2)); 150 | my $fileBlockSize = unpack("n",substr($entry,14,2)); 151 | 152 | my $fileData = ''; 153 | my $extra = ''; 154 | if ( ( $fileBlockStart + $fileBlockSize ) * $blockSize <= $directoryIndex ) { 155 | for ( my $j = 0; $j < $fileBlockSize; $j++ ) { 156 | my $block = substr($bramData,($j+$fileBlockStart) * $blockSize,$blockSize); 157 | if ( $fileDatProt ) { 158 | $block = &BRAMDecodeDataProtectedBlock($block); 159 | } 160 | $fileData .= $block; 161 | } 162 | if ( open(SAV, '>'.$prefix.$fileName.'.SAV') ) { 163 | binmode SAV; 164 | print SAV $fileData; 165 | } 166 | close SAV; 167 | 168 | if ( $fileData !~ /[^\x00]/ ) { 169 | $extra = ' (data is all zeros)'; 170 | } 171 | } else { 172 | $extra = ' (invalid start/offset)'; 173 | } 174 | $table .= sprintf("| %s | %s | %2.2X | %4.4X | %4.4X |%s\n",$drive,$fileName,$fileDatProt,$fileBlockStart,$fileBlockSize,$extra); 175 | 176 | } 177 | } 178 | return $table; 179 | } 180 | 181 | 182 | 183 | 184 | sub BRAMDecodeDataProtectedBlock { 185 | my ($dataIn) = @_; 186 | if ( length($dataIn) != $blockSize ) { 187 | die "Bad block\n"; 188 | } 189 | my $dataOut = ''; 190 | my $bitsCollector = 0; 191 | my $bitsCollected = 0; 192 | my $dataInIndex = 2; 193 | my $bytesCollected = 0; 194 | 195 | $bitsCollector = ( ord(substr($dataIn,$dataInIndex++,1)) & 0x0C ) << 12; 196 | $bitsCollected = 2; 197 | 198 | while ( $bytesCollected < 0x20 ) { 199 | $bitsCollector = $bitsCollector | ( ( ord(substr($dataIn,$dataInIndex++,1)) & 0xFC ) << ( 8 - $bitsCollected ) ); 200 | $bitsCollected += 6; 201 | if ( $bitsCollected >= 8 ) { 202 | $dataOut .= chr( ( $bitsCollector >> 8 ) & 0x00FF ); 203 | $bytesCollected++; 204 | $bitsCollector = $bitsCollector << 8; 205 | $bitsCollected -= 8; 206 | } 207 | } 208 | 209 | return $dataOut; 210 | } 211 | 212 | 213 | sub Help { 214 | die ' 215 | scdbrm 216 | 217 | [description] 218 | Decodes directory to screen and outputs each file (decodes data protected). 219 | Also generates out.bin which is every block decoded as if it was data 220 | protected. Treats *.crm and *.CRM files as RAM catridge only data. 221 | All other files are treated as Gens style brm files (first 8k represents 222 | internal RAM and any data after that is the optional RAM cartridge data). 223 | 224 | '; 225 | } 226 | -------------------------------------------------------------------------------- /scdgamegenie: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2012 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | # Used Genesis game genie information located at: 20 | # Game Genie Encryption Schemes by Lazy Bastard 21 | # http://gamehacking.org/?s=faqs&id=114 22 | ############################################################################### 23 | 24 | use strict; 25 | use warnings; 26 | 27 | if ( $#ARGV < 0 ) { 28 | &Help(); 29 | } 30 | 31 | my $mapAV2GG = 'ABCDEFGHJKLMNPRSTVWXYZ0123456789'; 32 | 33 | my %mapGG2AV = ( 34 | 'A' => 0b00000, 35 | 'B' => 0b00001, 36 | 'C' => 0b00010, 37 | 'D' => 0b00011, 38 | 'E' => 0b00100, 39 | 'F' => 0b00101, 40 | 'G' => 0b00110, 41 | 'H' => 0b00111, 42 | 'J' => 0b01000, 43 | 'K' => 0b01001, 44 | 'L' => 0b01010, 45 | 'M' => 0b01011, 46 | 'N' => 0b01100, 47 | 'P' => 0b01101, 48 | 'R' => 0b01110, 49 | 'S' => 0b01111, 50 | 'T' => 0b10000, 51 | 'V' => 0b10001, 52 | 'W' => 0b10010, 53 | 'X' => 0b10011, 54 | 'Y' => 0b10100, 55 | 'Z' => 0b10101, 56 | '0' => 0b10110, 57 | '1' => 0b10111, 58 | '2' => 0b11000, 59 | '3' => 0b11001, 60 | '4' => 0b11010, 61 | '5' => 0b11011, 62 | '6' => 0b11100, 63 | '7' => 0b11101, 64 | '8' => 0b11110, 65 | '9' => 0b11111 66 | ); 67 | 68 | foreach my $arg (@ARGV) { 69 | if ( $arg =~ m/^\s*([$mapAV2GG]{4})\s*-\s*([$mapAV2GG]{4})\s*$/ ) { 70 | # convert game genie code to address/value 71 | my $gg0 = $1; 72 | my $gg1 = $2; 73 | my @chars; 74 | for ( my $i = 0; $i < 4; $i++ ) { 75 | $chars[0+$i] = $mapGG2AV{substr($gg0,$i,1)}; 76 | $chars[4+$i] = $mapGG2AV{substr($gg1,$i,1)}; 77 | } 78 | # 0 1 2 3 - 4 5 6 7 79 | # GG: ijklm nopIJ KLMNO PABCD - EFGHd efgha bcQRS TUVWX 80 | # 0 1 2 : 3 4 81 | # AV: ABCDEFGH IJKLMNOP QRSTUVWX : abcdefgh ijklmnop 82 | my @bytes; 83 | $bytes[0] = 84 | ( ( ( $chars[3] >> 3 ) & 1 ) << 7 ) | 85 | ( ( ( $chars[3] >> 2 ) & 1 ) << 6 ) | 86 | ( ( ( $chars[3] >> 1 ) & 1 ) << 5 ) | 87 | ( ( ( $chars[3] >> 0 ) & 1 ) << 4 ) | 88 | ( ( ( $chars[4] >> 4 ) & 1 ) << 3 ) | 89 | ( ( ( $chars[4] >> 3 ) & 1 ) << 2 ) | 90 | ( ( ( $chars[4] >> 2 ) & 1 ) << 1 ) | 91 | ( ( ( $chars[4] >> 1 ) & 1 ) << 0 ); 92 | $bytes[1] = 93 | ( ( ( $chars[1] >> 1 ) & 1 ) << 7 ) | 94 | ( ( ( $chars[1] >> 0 ) & 1 ) << 6 ) | 95 | ( ( ( $chars[2] >> 4 ) & 1 ) << 5 ) | 96 | ( ( ( $chars[2] >> 3 ) & 1 ) << 4 ) | 97 | ( ( ( $chars[2] >> 2 ) & 1 ) << 3 ) | 98 | ( ( ( $chars[2] >> 1 ) & 1 ) << 2 ) | 99 | ( ( ( $chars[2] >> 0 ) & 1 ) << 1 ) | 100 | ( ( ( $chars[3] >> 4 ) & 1 ) << 0 ); 101 | $bytes[2] = 102 | ( ( ( $chars[6] >> 2 ) & 1 ) << 7 ) | 103 | ( ( ( $chars[6] >> 1 ) & 1 ) << 6 ) | 104 | ( ( ( $chars[6] >> 0 ) & 1 ) << 5 ) | 105 | ( ( ( $chars[7] >> 4 ) & 1 ) << 4 ) | 106 | ( ( ( $chars[7] >> 3 ) & 1 ) << 3 ) | 107 | ( ( ( $chars[7] >> 2 ) & 1 ) << 2 ) | 108 | ( ( ( $chars[7] >> 1 ) & 1 ) << 1 ) | 109 | ( ( ( $chars[7] >> 0 ) & 1 ) << 0 ); 110 | $bytes[3] = 111 | ( ( ( $chars[5] >> 0 ) & 1 ) << 7 ) | 112 | ( ( ( $chars[6] >> 4 ) & 1 ) << 6 ) | 113 | ( ( ( $chars[6] >> 3 ) & 1 ) << 5 ) | 114 | ( ( ( $chars[4] >> 0 ) & 1 ) << 4 ) | 115 | ( ( ( $chars[5] >> 4 ) & 1 ) << 3 ) | 116 | ( ( ( $chars[5] >> 3 ) & 1 ) << 2 ) | 117 | ( ( ( $chars[5] >> 2 ) & 1 ) << 1 ) | 118 | ( ( ( $chars[5] >> 1 ) & 1 ) << 0 ); 119 | $bytes[4] = 120 | ( ( ( $chars[0] >> 4 ) & 1 ) << 7 ) | 121 | ( ( ( $chars[0] >> 3 ) & 1 ) << 6 ) | 122 | ( ( ( $chars[0] >> 2 ) & 1 ) << 5 ) | 123 | ( ( ( $chars[0] >> 1 ) & 1 ) << 4 ) | 124 | ( ( ( $chars[0] >> 0 ) & 1 ) << 3 ) | 125 | ( ( ( $chars[1] >> 4 ) & 1 ) << 2 ) | 126 | ( ( ( $chars[1] >> 3 ) & 1 ) << 1 ) | 127 | ( ( ( $chars[1] >> 2 ) & 1 ) << 0 ); 128 | 129 | my $addressValue = 130 | ( $bytes[0] << 16 ) | 131 | ( $bytes[1] << 8 ) | 132 | ( $bytes[2] << 0 ); 133 | my $valueValue = 134 | ( $bytes[3] << 8 ) | 135 | ( $bytes[4] << 0 ); 136 | my $address = sprintf("%6.6X",$addressValue); 137 | my $value = sprintf("%4.4X",$valueValue); 138 | print "$gg0-$gg1 <=> $address:$value\n"; 139 | } elsif ( $arg =~ m/^\s*([0-9A-F]{6})\s*:\s*([0-9A-F]{4})\s*$/ ) { 140 | # convert address/value to game genie code 141 | my $address = $1; 142 | my $value = $2; 143 | my @bytes; 144 | $bytes[0] = hex(substr($address,0,2)); 145 | $bytes[1] = hex(substr($address,2,2)); 146 | $bytes[2] = hex(substr($address,4,2)); 147 | $bytes[3] = hex(substr($value,0,2)); 148 | $bytes[4] = hex(substr($value,2,2)); 149 | # 0 1 2 : 3 4 150 | # AV: ABCDEFGH IJKLMNOP QRSTUVWX : abcdefgh ijklmnop 151 | # 0 1 2 3 - 4 5 6 7 152 | # GG: ijklm nopIJ KLMNO PABCD - EFGHd efgha bcQRS TUVWX 153 | my @chars; 154 | $chars[0] = 155 | ( ( ( $bytes[4] >> 7 ) & 1 ) << 4 ) | 156 | ( ( ( $bytes[4] >> 6 ) & 1 ) << 3 ) | 157 | ( ( ( $bytes[4] >> 5 ) & 1 ) << 2 ) | 158 | ( ( ( $bytes[4] >> 4 ) & 1 ) << 1 ) | 159 | ( ( ( $bytes[4] >> 3 ) & 1 ) << 0 ); 160 | $chars[1] = 161 | ( ( ( $bytes[4] >> 2 ) & 1 ) << 4 ) | 162 | ( ( ( $bytes[4] >> 1 ) & 1 ) << 3 ) | 163 | ( ( ( $bytes[4] >> 0 ) & 1 ) << 2 ) | 164 | ( ( ( $bytes[1] >> 7 ) & 1 ) << 1 ) | 165 | ( ( ( $bytes[1] >> 6 ) & 1 ) << 0 ); 166 | $chars[2] = 167 | ( ( ( $bytes[1] >> 5 ) & 1 ) << 4 ) | 168 | ( ( ( $bytes[1] >> 4 ) & 1 ) << 3 ) | 169 | ( ( ( $bytes[1] >> 3 ) & 1 ) << 2 ) | 170 | ( ( ( $bytes[1] >> 2 ) & 1 ) << 1 ) | 171 | ( ( ( $bytes[1] >> 1 ) & 1 ) << 0 ); 172 | $chars[3] = 173 | ( ( ( $bytes[1] >> 0 ) & 1 ) << 4 ) | 174 | ( ( ( $bytes[0] >> 7 ) & 1 ) << 3 ) | 175 | ( ( ( $bytes[0] >> 6 ) & 1 ) << 2 ) | 176 | ( ( ( $bytes[0] >> 5 ) & 1 ) << 1 ) | 177 | ( ( ( $bytes[0] >> 4 ) & 1 ) << 0 ); 178 | $chars[4] = 179 | ( ( ( $bytes[0] >> 3 ) & 1 ) << 4 ) | 180 | ( ( ( $bytes[0] >> 2 ) & 1 ) << 3 ) | 181 | ( ( ( $bytes[0] >> 1 ) & 1 ) << 2 ) | 182 | ( ( ( $bytes[0] >> 0 ) & 1 ) << 1 ) | 183 | ( ( ( $bytes[3] >> 4 ) & 1 ) << 0 ); 184 | $chars[5] = 185 | ( ( ( $bytes[3] >> 3 ) & 1 ) << 4 ) | 186 | ( ( ( $bytes[3] >> 2 ) & 1 ) << 3 ) | 187 | ( ( ( $bytes[3] >> 1 ) & 1 ) << 2 ) | 188 | ( ( ( $bytes[3] >> 0 ) & 1 ) << 1 ) | 189 | ( ( ( $bytes[3] >> 7 ) & 1 ) << 0 ); 190 | $chars[6] = 191 | ( ( ( $bytes[3] >> 6 ) & 1 ) << 4 ) | 192 | ( ( ( $bytes[3] >> 5 ) & 1 ) << 3 ) | 193 | ( ( ( $bytes[2] >> 7 ) & 1 ) << 2 ) | 194 | ( ( ( $bytes[2] >> 6 ) & 1 ) << 1 ) | 195 | ( ( ( $bytes[2] >> 5 ) & 1 ) << 0 ); 196 | $chars[7] = 197 | ( ( ( $bytes[2] >> 4 ) & 1 ) << 4 ) | 198 | ( ( ( $bytes[2] >> 3 ) & 1 ) << 3 ) | 199 | ( ( ( $bytes[2] >> 2 ) & 1 ) << 2 ) | 200 | ( ( ( $bytes[2] >> 1 ) & 1 ) << 1 ) | 201 | ( ( ( $bytes[2] >> 0 ) & 1 ) << 0 ); 202 | my $gg0 = 203 | substr($mapAV2GG,$chars[0],1) . 204 | substr($mapAV2GG,$chars[1],1) . 205 | substr($mapAV2GG,$chars[2],1) . 206 | substr($mapAV2GG,$chars[3],1); 207 | my $gg1 = 208 | substr($mapAV2GG,$chars[4],1) . 209 | substr($mapAV2GG,$chars[5],1) . 210 | substr($mapAV2GG,$chars[6],1) . 211 | substr($mapAV2GG,$chars[7],1); 212 | print "$gg0-$gg1 <=> $address:$value\n"; 213 | } else { 214 | print STDERR "Could not parse: $arg\n"; 215 | } 216 | } 217 | 218 | 219 | sub Help { 220 | die ' 221 | scdgamegenie [codes] 222 | 223 | [description] 224 | Convert to and from game genie code format. 225 | 226 | [codes] 227 | XXXX-XXXX convert game genie code to address/value 228 | XXXXXX:XXXX convert address/value to game genie code 229 | 230 | '; 231 | } 232 | -------------------------------------------------------------------------------- /scdbin2asmdata: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2012 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | # TODO z80 support 21 | 22 | use strict; 23 | use warnings; 24 | 25 | my $z80 = 0; 26 | 27 | my $verbosity = 2; 28 | 29 | my $directive = ''; 30 | my $directiveSize = -1; 31 | my $directiveCount = 8; 32 | my $directiveLineBreak = ''; 33 | 34 | my $binFileIn = ''; 35 | my $asmFile = ''; 36 | my $bin = 0; 37 | 38 | my $offset = 0; 39 | my $length = 0; 40 | my $end = 0; 41 | my $repeat = 1; 42 | 43 | sub ArgNumber { 44 | my ($type,$num) = @_; 45 | my $value = 0; 46 | if ( $num =~ /^(\d+)$/i ) { 47 | $value = $1; 48 | } elsif ( $num =~ /^(0x|\$)([0-9A-F]+)$/i ) { 49 | $value = hex($2); 50 | } else { 51 | die "Bad num logic: ($type,$num)\n"; 52 | } 53 | if ( $type eq '' || $type eq 'byte' ) { 54 | # do nothing 55 | } elsif ( $type eq 'word' ) { 56 | $value *= 2; 57 | } elsif ( $type eq 'long' ) { 58 | $value *= 4; 59 | } elsif ( $type eq 'pal' || $type eq 'tile' ) { 60 | $value *= 32; 61 | } else { 62 | die "Bad type logic: ($type,$num)\n"; 63 | } 64 | return $value; 65 | } 66 | 67 | my @args; 68 | foreach my $arg (@ARGV) { 69 | if ( $arg =~ /^-(|byte|word|long|pal|tile)offset=([\d+|(0x|\$)[0-9A-F]+)$/i ) { 70 | $offset = &ArgNumber($1,$2); 71 | } elsif ( $arg =~ /^-(|byte|word|long|pal|tile)length=([\d+|(0x|\$)[0-9A-F]+)$/i ) { 72 | $length = &ArgNumber($1,$2); 73 | } elsif ( $arg =~ /^-(|byte|word|long|pal|tile)end=([\d+|(0x|\$)[0-9A-F]+)$/i ) { 74 | $end = &ArgNumber($1,$2); 75 | } elsif ( $arg =~ m/^-z80$/i ) { 76 | $z80 = 1; 77 | } elsif ( $arg =~ m/^-68k$/i ) { 78 | $z80 = 0; 79 | } elsif ( $arg =~ m/^-bin$/i ) { 80 | $bin = 1; 81 | } elsif ( $arg =~ m/^-directive=(.+)$/i ) { 82 | $directive = $1; 83 | } elsif ( $arg =~ m/^-directivesize=(\d+)$/i ) { 84 | $directiveSize = $1; 85 | } elsif ( $arg =~ m/^-directivecount=(\d+)$/i ) { 86 | $directiveCount = $1; 87 | } elsif ( $arg =~ m/^-(directive)?linebreak=(.+)$/i ) { 88 | $directiveLineBreak = $2; 89 | } elsif ( $arg =~ /^-repeat=(\d+)$/i ) { 90 | $repeat = $1; 91 | if ( $repeat < 1 ) { 92 | &Help(); 93 | } 94 | } elsif ( $arg =~ /^-v=(\d+)$/i ) { 95 | $verbosity = $1; 96 | } else { 97 | push @args, $arg; 98 | } 99 | } 100 | 101 | if ( ! $bin ) { 102 | if ( $directive eq '' ) { 103 | if ( $z80 ) { 104 | if ( $directiveSize == 1 || 105 | $directiveSize < 0 ) { 106 | $directive = 'db'; 107 | $directiveSize = 1; 108 | } elsif ( $directiveSize == 2 ) { 109 | $directive = 'dw'; 110 | } else { 111 | print STDERR "Cannot understand directiveSize \"$directiveSize\" and did not specify -directive\n"; 112 | &Help(); 113 | } 114 | } else { 115 | if ( $directiveSize == 1 ) { 116 | $directive = 'dc.b'; 117 | } elsif ( $directiveSize == 2 || 118 | $directiveSize < 0 ) { 119 | $directive = 'dc.w'; 120 | $directiveSize = 2; 121 | } elsif ( $directiveSize == 4 ) { 122 | $directive = 'dc.l'; 123 | } else { 124 | print STDERR "Cannot understand directiveSize \"$directiveSize\" and did not specify -directive\n"; 125 | &Help(); 126 | } 127 | } 128 | } 129 | if ( $directiveSize <= 0 ) { 130 | if ( $directive =~ /^dc\.b$/i || 131 | $directive =~ /^db$/i ) { 132 | $directiveSize = 1; 133 | } elsif ( $directive =~ /^dc\.w$/i || 134 | $directive =~ /^dw$/i ) { 135 | $directiveSize = 2; 136 | } elsif ( $directive =~ /^dc\.l$/i ) { 137 | $directiveSize = 4; 138 | } else { 139 | print STDERR "Cannot understand directive \"$directive\" and did not specify -directiveSize\n"; 140 | &Help(); 141 | } 142 | } 143 | } 144 | 145 | if ( $#args == 0 && ! $bin ) { 146 | # should not print out binary data 147 | $binFileIn = $args[0]; 148 | $asmFile = ''; 149 | } elsif ( $#args == 1 ) { 150 | $binFileIn = $args[0]; 151 | $asmFile = $args[1]; 152 | } else { 153 | &Help(); 154 | } 155 | 156 | my $binFile = $binFileIn; 157 | if ( $binFileIn =~ m/\.(asm|68k|z80)$/i ) { 158 | $binFile = 'TMP.BIN'; 159 | system("scdasm -v=$verbosity $binFileIn $binFile"); 160 | if ( ! -e $binFile ) { 161 | die "Bad scdasm since didn't make: $binFile"; 162 | } 163 | } 164 | 165 | my $binSize = -s $binFile; 166 | 167 | if ( $end > 0 ) { 168 | if ( $offset >= $end ) { 169 | die "start before end...\n"; 170 | } 171 | my $lengthNew = $end - $offset; 172 | if ( $length > 0 && $length != $lengthNew ) { 173 | die "specified length ($length) doesn't match specified offset ($offset) and specified end ($end)\n"; 174 | } 175 | $length = $lengthNew; 176 | } 177 | if ( $offset + $length > $binSize ) { 178 | die "Input offset($offset)/length($length) exceeds input file length($binSize)\n"; 179 | } 180 | if ( $length <= 0 ) { 181 | $length = $binSize - $offset; 182 | } 183 | 184 | # TODO hard code usage into option 185 | # 0x200; 186 | my $alignComment = 0; 187 | 188 | my $asmData = ''; 189 | if ( open(BIN, $binFile) ) { 190 | binmode BIN; 191 | if ( $offset ) { 192 | seek(BIN,$offset,0); 193 | } 194 | if ( $bin ) { 195 | $asmData = chr(0x00) x $length; 196 | read(BIN,$asmData,$length); 197 | } else { 198 | my $directiveIndex = 0; 199 | my $directiveEntryValue = ''; 200 | for ( my $binIndex = 0; $binIndex < $length; $binIndex += $directiveSize ) { 201 | if ( $alignComment && ( $binIndex + $offset ) % $alignComment == 0 ) { 202 | # TODO z80 support? 203 | $asmData .= sprintf("\t;; \$%8.8X\n",$binIndex+$offset); 204 | } 205 | # TODO ignore error for now 206 | read(BIN,$directiveEntryValue,$directiveSize); 207 | if ( $directiveIndex <= 0 ) { 208 | $asmData .= "\t$directive\t"; 209 | } else { 210 | $asmData .= ","; 211 | } 212 | if ( $z80 && $directiveSize > 1 ) { 213 | # reverse the endian 214 | $directiveEntryValue = scalar reverse $directiveEntryValue; 215 | } 216 | my $valuePrefix = ''; 217 | my $value = ''; 218 | if ( $z80 ) { 219 | $valuePrefix = '0'; 220 | $value = uc(unpack("H*",$directiveEntryValue))."H"; 221 | } else { 222 | $valuePrefix = '$'; 223 | $value = uc(unpack("H*",$directiveEntryValue)); 224 | } 225 | $asmData .= $valuePrefix.$value; 226 | $directiveIndex++; 227 | if ( $directiveIndex >= $directiveCount || 228 | ( $directiveLineBreak ne '' && 229 | $value =~ /^${directiveLineBreak}$/ ) ) { 230 | $asmData .= "\n"; 231 | $directiveIndex = 0; 232 | } 233 | } 234 | if ( $directiveIndex >= 0 ) { 235 | $asmData .= "\n"; 236 | $directiveIndex = 0; 237 | } 238 | } 239 | } 240 | 241 | close BIN; 242 | 243 | # delete any temporary files 244 | if ( $binFile ne $binFileIn ) { 245 | unlink $binFile; 246 | } 247 | 248 | if ( $asmFile eq '' || $asmFile eq '-' ) { 249 | print $asmData x $repeat; 250 | } else { 251 | if ( open( ASM, '>'.$asmFile ) ) { 252 | if ( $bin ) { 253 | binmode ASM; 254 | } 255 | print ASM $asmData x $repeat; 256 | } 257 | close ASM; 258 | } 259 | 260 | 261 | 262 | sub Help { 263 | die ' 264 | scdbin2asmdata [options] [outputfile] 265 | 266 | [description] 267 | Converts binary data to asm data. If the inputfile has ASM or 68K file 268 | extension, scdasm will be used to make a temporary binary file. If no output 269 | file is given, the asm data will be piped to standard output. Options 270 | allow changing the directives used to accomodate different styles and 271 | assemblers. Allows using a chunk of input file using offset/length. 272 | 273 | [sample output] 274 | the following is the default format for a single VDP palette (32 bytes) 275 | dc.w $0EEE,$0EEE,$0CCC,$0CCC,$0AAA,$0AAA,$0888,$0888 276 | dc.w $0666,$0666,$0444,$0444,$0222,$0222,$0000,$0000 277 | 278 | [options] 279 | -z80 uses z80 byte order (little endian) and 0XXH format 280 | -68k uses 68k byte order (big endian) and $XX format 281 | -directive= specifies directive, such as dc.b, dc.w, etc 282 | -directivesize=<#> number of bytes used in each directive entry 283 | -directivecount=<#> number of directive entries per line 284 | -linebreak= will cut the line short if value matches regex 285 | (default none) (ex: -cutshort=FFFF) 286 | -bin outputs a binary file instead 287 | -v=<#> specify verbosity 288 | -offset=<#> byte offset in keyword file (default 0) 289 | -length=<#> byte length of keyword (default remainder of keyword file) 290 | -end=<#> byte end of keyword 291 | -wordoffset=<#> word offset in keyword file 292 | -wordlength=<#> word length of keyword 293 | -wordend=<#> word end in keyword file 294 | -longoffset=<#> long (4 byte) offset in keyword file 295 | -longlength=<#> long (4 byte) length of keyword 296 | -longend=<#> long (4 byte) end of keyword 297 | -tileoffset=<#> tile (32 byte) offset in keyword file 298 | -tilelength=<#> tile (32 byte) length of keyword 299 | -tileend=<#> tile (32 byte) end of keyword 300 | -paloffset=<#> pal (32 byte) offset in keyword file 301 | -pallength=<#> pal (32 byte) length of keyword 302 | -palend=<#> pal (32 byte) end of keyword 303 | -repeat=<#> repeat a desired amount of times (default 1) 304 | 305 | '; 306 | } 307 | -------------------------------------------------------------------------------- /scdips: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2015 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | use strict; 21 | use warnings; 22 | 23 | if ( $#ARGV < 2 ) { 24 | &Help(); 25 | } 26 | 27 | my $type = shift @ARGV; 28 | my $make = 0; 29 | if ( $type =~ /^\s*patch\s*$/i ) { 30 | $make = 0; 31 | } elsif ( $type =~ /^\s*make\s*$/i ) { 32 | $make = 1; 33 | # } elsif ( $type =~ /^\s*text\s*$/i ) { 34 | # $make = 2; 35 | } else { 36 | print STDERR "Need to specify convert or make\n"; 37 | &Help(); 38 | } 39 | 40 | if ( $#ARGV < 1 || $#ARGV > 2 ) { 41 | &Help(); 42 | } 43 | 44 | my $ipsFile = $ARGV[0]; 45 | my $romFile0 = $ARGV[1]; 46 | my $romFile1 = $#ARGV < 2 ? $romFile0 : $ARGV[2]; 47 | 48 | my $verbosity = 2; 49 | 50 | my $romFile0Length = -s $romFile0; 51 | my $romFile0Data = ''; 52 | 53 | open( ROM, $romFile0 ) or die "Could not read file: $romFile0\n"; 54 | binmode ROM; 55 | read( ROM, $romFile0Data, $romFile0Length ); 56 | close ROM; 57 | 58 | sub IPSMakeRecord { 59 | my ($diffStart,$diffEnd,$data) = @_; 60 | my $ipsData = ''; 61 | # avoid invalid large start 62 | if ( $diffStart > 0xFFFFFF ) { 63 | $diffStart = 0xFFFFFF; 64 | } 65 | if ( $diffStart == 0x454F46 ) { 66 | $diffStart--; 67 | } 68 | while ( $diffStart <= $diffEnd ) { 69 | my $diffLength = $diffEnd-$diffStart+1; 70 | my $diffStartNext; 71 | if ( $diffLength > 0xFFFF ) { 72 | $diffStartNext = $diffStart + 0xFFFF; 73 | if ( $diffStartNext > 0xFFFFFF ) { 74 | $diffStartNext = 0xFFFFFF; 75 | } 76 | } else { 77 | $diffStartNext = $diffStart + $diffLength; 78 | } 79 | my $size = $diffStartNext-$diffStart; 80 | $ipsData .= 81 | substr(pack("N",$diffStart),1,3) . 82 | pack("n",$size) . 83 | substr($data,$diffStart,$size); 84 | if ( $verbosity >= 2 ) { 85 | printf("IPS normal record: offset=0x%6.6X size=0x%4.4X\n",$diffStart,$size); 86 | } 87 | $diffStart = $diffStartNext; 88 | } 89 | return $ipsData; 90 | } 91 | 92 | if ( $make == 1 ) { 93 | my $romFile1Length = -s $romFile1; 94 | my $romFile1Data = ''; 95 | 96 | if ( $romFile1Length < $romFile0Length ) { 97 | die "Cannot create patch which makes file smaller\n"; 98 | } 99 | if ( $romFile1Length > 0xFFFFFF + 0xFFFF ) { 100 | die "File exceeds patch length\n"; 101 | } 102 | 103 | open( ROM, $romFile1 ) or die "Could not read file: $romFile1\n"; 104 | binmode ROM; 105 | read( ROM, $romFile1Data, $romFile1Length ); 106 | close ROM; 107 | 108 | my $ipsData = ''; 109 | 110 | my $diffStart = 0; 111 | my $diffEnd = 0; 112 | my $diffIn = 0; 113 | # can make it align on other boundaries besides per byte... 114 | my $operandSize = 1; 115 | # if differences have 5 bytes the same in the middle same amount of 116 | # bytes in patch 117 | # does not do RLE intentionally since may not be supported everywhere 118 | for ( my $i = 0; $i < $romFile1Length; $i += $operandSize ) { 119 | if ( $i + $operandSize > $romFile0Length ) { 120 | if ( ! $diffIn ) { 121 | $diffStart = $i; 122 | } 123 | $diffIn = 0; 124 | $ipsData .= &IPSMakeRecord($diffStart,$romFile1Length-1,$romFile1Data); 125 | last; 126 | } 127 | if ( substr($romFile0Data,$i,$operandSize) ne substr($romFile1Data,$i,$operandSize) ) { 128 | if ( ! $diffIn ) { 129 | $diffStart = $i; 130 | $diffIn = 1; 131 | } 132 | $diffEnd = $i + $operandSize - 1; 133 | } else { 134 | if ( $diffIn && $i > $diffEnd + 5 ) { 135 | $ipsData .= &IPSMakeRecord($diffStart,$diffEnd,$romFile1Data); 136 | $diffIn = 0; 137 | } 138 | } 139 | } 140 | if ( $diffIn ) { 141 | $ipsData .= &IPSMakeRecord($diffStart,$diffEnd,$romFile1Data); 142 | } 143 | 144 | if ( $ipsData eq '' ) { 145 | die "No patch needed.\n"; 146 | } 147 | 148 | $ipsData = 'PATCH'.$ipsData.'EOF'; 149 | 150 | open( IPS, '>'.$ipsFile ) or die "Could not read file: $ipsFile\n"; 151 | binmode IPS; 152 | print IPS $ipsData; 153 | close IPS; 154 | } elsif ( $make == 0 ) { 155 | my $ipsLength = -s $ipsFile; 156 | my $ipsData = ''; 157 | 158 | open( IPS, $ipsFile ) or die "Could not read file: $ipsFile\n"; 159 | binmode IPS; 160 | read( IPS, $ipsData, $ipsLength ); 161 | close IPS; 162 | 163 | my $romFile1Data = $romFile0Data; 164 | 165 | my $ipsOffset = 5; 166 | 167 | if ( $ipsLength < 8 || substr($ipsData,0,5) ne 'PATCH' ) { 168 | die "Not a valid IPS file: $ipsFile\n"; 169 | } 170 | 171 | if ( $verbosity >= 2 ) { 172 | print "IPS PATCH\n"; 173 | } 174 | 175 | while (1) { 176 | if ( $ipsOffset + 3 > $ipsLength ) { 177 | die "Invalid IPS data since searching past end of file for more records\n"; 178 | } 179 | my $offsetString = substr($ipsData,$ipsOffset,3); 180 | $ipsOffset += 3; 181 | if ( $offsetString eq "EOF" ) { 182 | if ( $verbosity >= 2 ) { 183 | print "IPS EOF\n"; 184 | } 185 | last; 186 | } 187 | my $offset = unpack("N",chr(0x00).$offsetString); 188 | if ( $ipsOffset + 2 > $ipsLength ) { 189 | die "Invalid IPS data\n"; 190 | } 191 | my $sizeString = substr($ipsData,$ipsOffset,2); 192 | $ipsOffset += 2; 193 | my $size = unpack("n",$sizeString); 194 | if ( $size > 0 ) { 195 | # normal patch record 196 | if ( $verbosity >= 2 ) { 197 | printf("IPS normal record: offset=0x%6.6X size=0x%4.4X\n",$offset,$size); 198 | } 199 | if ( $ipsOffset + $size > $ipsLength ) { 200 | die "Invalid IPS data\n"; 201 | } 202 | if ( $offset > $romFile0Length ) { 203 | print STDERR "IPS patch is skipping bytes between end and patch, inserting zeros\n"; 204 | } 205 | if ( $offset + $size > $romFile0Length ) { 206 | # need to lengthen the ROM 207 | $romFile1Data .= chr(0x00) x ( $offset + $size - $romFile0Length ); 208 | $romFile0Length = $offset + $size; 209 | } 210 | my $data = substr($ipsData,$ipsOffset,$size); 211 | substr($romFile1Data,$offset,$size) = $data; 212 | $ipsOffset += $size; 213 | } else { 214 | # RLE patch record 215 | if ( $ipsOffset + 3 > $ipsLength ) { 216 | die "Invalid IPS data\n"; 217 | } 218 | my $repeatString = substr($ipsData,$ipsOffset,2); 219 | $ipsOffset += 2; 220 | my $repeat = unpack("n",$repeatString); 221 | my $data = substr($ipsData,$ipsOffset,1); 222 | $ipsOffset += 1; 223 | if ( $verbosity >= 2 ) { 224 | printf("IPS RLE record: offset=0x%6.6X repeat=0x%4.4X data=0x%2.2X\n",$offset,$repeat,ord($data)); 225 | } 226 | if ( $offset > $romFile0Length ) { 227 | print STDERR "IPS patch is skipping bytes between end and patch, inserting zeros\n"; 228 | } 229 | if ( $offset + $repeat > $romFile0Length ) { 230 | # need to lengthen the ROM 231 | $romFile1Data .= chr(0x00) x ( $offset + $repeat - $romFile0Length ); 232 | $romFile0Length = $offset + $repeat; 233 | } 234 | substr($romFile1Data,$offset,$repeat) = ( $data x $repeat ); 235 | } 236 | } 237 | 238 | if ( $ipsOffset != $ipsLength ) { 239 | print STDERR "Unused data at end of IPS file?\n"; 240 | } 241 | 242 | open( ROM, '>'.$romFile1 ) or die "Could not read file: $romFile1\n"; 243 | binmode ROM; 244 | print ROM $romFile1Data; 245 | close ROM; 246 | # } elsif ( $make == 2 ) { 247 | # # text 248 | # open( TEXT, $ipsFile ) or die "Could not read file: $ipsFile\n"; 249 | 250 | # my $romFile1Data = $romFile0Data; 251 | 252 | # while ( my $textLine = ) { 253 | # chomp $textLine; 254 | # # remove comments (;) 255 | # $textLine =~ s/^([^;]*);.*$/$1/; 256 | # my $addr = 0; 257 | # my $src = ''; 258 | # my $dest = ''; 259 | # if ( $textLine =~ /^\s*(?:0x|\$)([0-9A-F]+)\s*:\s*(?:0x|\$)([0-9A-F]+)\s*->\s*(?:0x|\$)([0-9A-F]+)\s*$/ ) { 260 | # $addr = hex($1); 261 | # $src = $2; 262 | # $dest = $3; 263 | # } elsif ( $textLine =~ /^\s*(?:0x|\$)([0-9A-F]+)\s*:\s*(?:0x|\$)([0-9A-F]+)\s*$/ ) { 264 | # $addr = hex($1); 265 | # $dest = $2; 266 | # } elsif ( $textLine !~ /^\s*$/ ) { 267 | # die "Unparsed line: $textLine\n"; 268 | # } 269 | # if ( $src ne '' ) { 270 | # my $srcPacked = pack("H*",$src); 271 | # my $srcPackedLength = length($srcPacked); 272 | # if ( $addr+$srcPackedLength <= $romFile0Length && 273 | # substr($romFile1Data,$addr,$srcPackedLength) eq $srcPacked ) { 274 | # # src matches 275 | # } else { 276 | # print STDERR "textline: ".$textLine."\n"; 277 | # print STDERR "source: ".unpack("H*",substr($romFile1Data,$addr,$srcPackedLength))."\n"; 278 | # die "Source data in text patch does not match binary file data for address\n"; 279 | # } 280 | # } 281 | # if ( $dest ne '' ) { 282 | # my $destPacked = pack("H*",$dest); 283 | # my $destPackedLength = length($destPacked); 284 | # # print "$textLine: $destPackedLength\n"; 285 | # if ( $addr+$destPackedLength <= $romFile0Length ) { 286 | # substr($romFile1Data,$addr,$destPackedLength) = $destPacked; 287 | # } else { 288 | # die "Dest data does not fit\n"; 289 | # } 290 | # } 291 | # } 292 | # close TEXT; 293 | 294 | # open( ROM, '>'.$romFile1 ) or die "Could not read file: $romFile1\n"; 295 | # binmode ROM; 296 | # print ROM $romFile1Data; 297 | # close ROM; 298 | } else { 299 | die "Bad logic\n"; 300 | } 301 | 302 | 303 | 304 | sub Help { 305 | die ' 306 | scdips patch [binfileout] 307 | scdips make 308 | 309 | [description] 310 | Patch updates binary file using IPS format. If binfileout is not specified 311 | updates binfile. 312 | Make makes a IPS file based on original and updated file. 313 | 314 | '; 315 | # removed text option, using scdpatchasm instead for my hacks 316 | # 317 | # scdips text [binfileout] 318 | # 319 | # Text uses a text based file for patching. 320 | # ; comments 321 | # $00100 : $00 -> $FF 322 | # $00102 : $80 323 | } 324 | -------------------------------------------------------------------------------- /scdcinepakencodeframe: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | 20 | use strict; 21 | use warnings; 22 | 23 | if ( $#ARGV < 0 ) { 24 | &Help(); 25 | } 26 | 27 | my $frameIndex = 0; 28 | my $tileDataLast = ''; 29 | my $tileDataLast2 = ''; 30 | my $tileDataSize = 0; 31 | 32 | # some cinepak fill the codebooks with unused entries 33 | my $codebooksFill = 0; 34 | 35 | my $frameEncodedPrefix = 'cinepaktiledata'; 36 | 37 | my @tileDataFiles; 38 | 39 | # parse args 40 | foreach my $arg (@ARGV) { 41 | if ( $arg =~ /^-codebooksfill$/i ) { 42 | $codebooksFill = 1; 43 | } elsif ( -e $arg ) { 44 | push @tileDataFiles, $arg; 45 | } else { 46 | print STDERR "\nCould not parse argument: $arg\n"; 47 | &Help(); 48 | } 49 | } 50 | 51 | foreach my $tileDataFile (@tileDataFiles) { 52 | my $tileDataFileSize = -s $tileDataFile; 53 | 54 | if ( $tileDataFileSize <= 0 || $tileDataFileSize % 32 != 0 ) { 55 | die "Frame files should be non-zero and on 32 byte boundary\n"; 56 | } 57 | 58 | if ( $tileDataSize > 0 && $tileDataSize != $tileDataFileSize ) { 59 | die "Every frame should be the same size\n"; 60 | } 61 | 62 | $tileDataSize = $tileDataFileSize; 63 | 64 | open( FRAME, '<'.$tileDataFile ) or die "Could not open $tileDataFile\n"; 65 | 66 | my $tileData = ''; 67 | 68 | if ( read( FRAME, $tileData, $tileDataSize ) != $tileDataSize ) { 69 | die "Could not read $tileDataFile contents\n"; 70 | } 71 | 72 | close FRAME; 73 | 74 | my $methodFlagsData = ''; 75 | my $methodFlagsCurrentLongWord = 0; 76 | my $methodFlagsShift = 30; 77 | my @methodFlagsCount = (0,0,0,0); 78 | 79 | my $codebook32Data = ''; 80 | my $codebook32Size = 0; 81 | 82 | my $codebook16Data = ''; 83 | my $codebook16Size = 0; 84 | 85 | my $vectorData = ''; 86 | 87 | my %tiles; 88 | 89 | { 90 | my %codebook32MapAll = (); 91 | 92 | # determine non-changing tiles and codebook 32 data 93 | for ( my $tileDataIndex = 0; $tileDataIndex < $tileDataSize; $tileDataIndex += 32 ) { 94 | my $tile = substr($tileData,$tileDataIndex,32); 95 | my $methodFlag = 0; 96 | if ( $frameIndex > 1 && 97 | $tile eq substr($tileDataLast2,$tileDataIndex,32) ) { 98 | # this tile has not changed 99 | $tiles{$tileDataIndex}{'data'} = ''; 100 | $tiles{$tileDataIndex}{'rank'} = -1; 101 | } else { 102 | $tiles{$tileDataIndex}{'data'} = $tile; 103 | $tiles{$tileDataIndex}{'rank'} = 32.25; 104 | for ( my $i = 0; $i < 32; $i += 8 ) { 105 | for ( my $j = 0; $j < 4; $j += 2 ) { 106 | my $k = substr($tile,$i+$j,2).substr($tile,$i+$j+4,2); 107 | if ( ! exists $codebook32MapAll{$k} ) { 108 | $codebook32MapAll{$k} = 1; 109 | } else { 110 | $codebook32MapAll{$k}++; 111 | } 112 | } 113 | } 114 | } 115 | } 116 | 117 | # rank each tile based on approximate bytes for codebook 32 usage 118 | # tiles that use popular codebook entries get a smaller rank 119 | foreach my $tileDecodedIndex (keys %tiles) { 120 | next if $tiles{$tileDecodedIndex}{'rank'} < 0; 121 | my $tile = $tiles{$tileDecodedIndex}{'data'}; 122 | my $rank = 8.25; 123 | for ( my $i = 0; $i < 32; $i += 8 ) { 124 | for ( my $j = 0; $j < 4; $j += 2 ) { 125 | my $k = substr($tile,$i+$j,2).substr($tile,$i+$j+4,2); 126 | $rank += 4 / $codebook32MapAll{$k}; 127 | } 128 | } 129 | $tiles{$tileDecodedIndex}{'rank'} = $rank; 130 | } 131 | } 132 | 133 | { 134 | my %codebook32Map = (); 135 | 136 | # now add the lowest ranked tiles first 137 | foreach my $tileDecodedIndex (sort { $tiles{$a}{'rank'} <=> $tiles{$b}{'rank'} } keys %tiles) { 138 | next if $tiles{$tileDecodedIndex}{'rank'} < 0; 139 | # if worst than uncompressed tile, don't do it... 140 | last if $tiles{$tileDecodedIndex}{'rank'} >= 40.25; 141 | my $tile = $tiles{$tileDecodedIndex}{'data'}; 142 | # see if have enough codebook 32 entries still 143 | my $entriesToAdd = 0; 144 | if ( $codebook32Size > 256 - 8 ) { 145 | my %codebook32MapAugment; 146 | for ( my $i = 0; $i < 32; $i += 8 ) { 147 | for ( my $j = 0; $j < 4; $j += 2 ) { 148 | my $k = substr($tile,$i+$j,2).substr($tile,$i+$j+4,2); 149 | if ( ! exists $codebook32Map{$k} && 150 | ! exists $codebook32MapAugment{$k} ) { 151 | $entriesToAdd++; 152 | $codebook32MapAugment{$k} = 1; 153 | } 154 | } 155 | } 156 | if ( 8.25 + $entriesToAdd * 4 > 32.25 ) { 157 | next; 158 | } 159 | } 160 | if ( $codebook32Size + $entriesToAdd <= 256 ) { 161 | my $tileNew = ''; 162 | for ( my $i = 0; $i < 32; $i += 8 ) { 163 | for ( my $j = 0; $j < 4; $j += 2 ) { 164 | my $k = substr($tile,$i+$j,2).substr($tile,$i+$j+4,2); 165 | my $vector; 166 | if ( ! exists $codebook32Map{$k} ) { 167 | $codebook32Data .= $k; 168 | $vector = chr($codebook32Size); 169 | $codebook32Map{$k} = $vector; 170 | $codebook32Size += 1; 171 | } else { 172 | $vector = $codebook32Map{$k}; 173 | } 174 | $tileNew .= $vector; 175 | } 176 | } 177 | $tiles{$tileDecodedIndex}{'data'} = $tileNew; 178 | $tiles{$tileDecodedIndex}{'rank'} = -2; 179 | } 180 | } 181 | } 182 | 183 | { 184 | my %codebook16MapAll = (); 185 | # get codebook 16 data for remaining tiles 186 | foreach my $tileDecodedIndex (keys %tiles) { 187 | next if $tiles{$tileDecodedIndex}{'rank'} < 0; 188 | my $tile = $tiles{$tileDecodedIndex}{'data'}; 189 | for ( my $i = 0; $i < 32; $i += 8 ) { 190 | for ( my $j = 0; $j < 4; $j += 1 ) { 191 | my $k = substr($tile,$i+$j,1).substr($tile,$i+$j+4,1); 192 | if ( ! exists $codebook16MapAll{$k} ) { 193 | $codebook16MapAll{$k} = 1; 194 | } else { 195 | $codebook16MapAll{$k}++; 196 | } 197 | } 198 | } 199 | } 200 | 201 | # rank each tile based on approximate bytes for codebook 32 usage 202 | # tiles that use popular codebook entries get a smaller rank 203 | foreach my $tileDecodedIndex (keys %tiles) { 204 | next if $tiles{$tileDecodedIndex}{'rank'} < 0; 205 | my $tile = $tiles{$tileDecodedIndex}{'data'}; 206 | my $rank = 16.25; 207 | for ( my $i = 0; $i < 32; $i += 8 ) { 208 | for ( my $j = 0; $j < 4; $j += 1 ) { 209 | my $k = substr($tile,$i+$j,1).substr($tile,$i+$j+4,1); 210 | $rank += 2 / $codebook16MapAll{$k}; 211 | } 212 | } 213 | $tiles{$tileDecodedIndex}{'rank'} = $rank; 214 | } 215 | } 216 | 217 | { 218 | my %codebook16Map = (); 219 | # now add the lowest ranked tiles first 220 | foreach my $tileDecodedIndex (sort { $tiles{$a}{'rank'} <=> $tiles{$b}{'rank'} } keys %tiles) { 221 | next if $tiles{$tileDecodedIndex}{'rank'} < 0; 222 | # if worst than uncompressed tile, don't do it... 223 | last if $tiles{$tileDecodedIndex}{'rank'} >= 48.25; 224 | my $tile = $tiles{$tileDecodedIndex}{'data'}; 225 | # see if have enough codebook 16 entries still 226 | my $entriesToAdd = 0; 227 | if ( $codebook16Size > 256 - 16 ) { 228 | my %codebook16MapAugment; 229 | for ( my $i = 0; $i < 32; $i += 8 ) { 230 | for ( my $j = 0; $j < 4; $j += 1 ) { 231 | my $k = substr($tile,$i+$j,1).substr($tile,$i+$j+4,1); 232 | if ( ! exists $codebook16Map{$k} && 233 | ! exists $codebook16MapAugment{$k} ) { 234 | $entriesToAdd++; 235 | $codebook16MapAugment{$k} = 1; 236 | } 237 | } 238 | } 239 | if ( 16.25 + $entriesToAdd * 2 > 32.25 ) { 240 | next; 241 | } 242 | } 243 | if ( $codebook16Size + $entriesToAdd <= 256 ) { 244 | my $tileNew = ''; 245 | for ( my $i = 0; $i < 32; $i += 8 ) { 246 | for ( my $j = 0; $j < 4; $j += 1 ) { 247 | my $k = substr($tile,$i+$j,1).substr($tile,$i+$j+4,1); 248 | my $vector; 249 | if ( ! exists $codebook16Map{$k} ) { 250 | $codebook16Data .= $k; 251 | $vector = chr($codebook16Size); 252 | $codebook16Map{$k} = $vector; 253 | $codebook16Size += 1; 254 | } else { 255 | $vector = $codebook16Map{$k}; 256 | } 257 | $tileNew .= $vector; 258 | } 259 | } 260 | $tiles{$tileDecodedIndex}{'data'} = $tileNew; 261 | $tiles{$tileDecodedIndex}{'rank'} = -2; 262 | } 263 | } 264 | } 265 | 266 | # now put the tiles back in order and make method data and vector data 267 | foreach my $tileDecodedIndex (sort { $a <=> $b } keys %tiles) { 268 | my $tile = $tiles{$tileDecodedIndex}{'data'}; 269 | my $tileLength = length($tile); 270 | my $methodFlag = 0; 271 | if ( $tileLength == 0 ) { 272 | $methodFlag = 0; 273 | } elsif ( $tileLength == 32 ) { 274 | $methodFlag = 1; 275 | } elsif ( $tileLength == 8 ) { 276 | $methodFlag = 2; 277 | } elsif ( $tileLength == 16 ) { 278 | $methodFlag = 3; 279 | } else { 280 | die "Error\n"; 281 | } 282 | 283 | $vectorData .= $tile; 284 | 285 | $methodFlagsCurrentLongWord |= ( $methodFlag & 3 ) << $methodFlagsShift; 286 | 287 | $methodFlagsShift -= 2; 288 | 289 | if ( $methodFlagsShift < 0 ) { 290 | $methodFlagsData .= pack("N",$methodFlagsCurrentLongWord); 291 | $methodFlagsCurrentLongWord = 0; 292 | $methodFlagsShift += 32; 293 | } 294 | 295 | $methodFlagsCount[$methodFlag] += 1; 296 | } 297 | 298 | print "$tileDataFile\n"; 299 | print " Method flags count: ".join(' ',@methodFlagsCount)."\n"; 300 | print " Codebook32 count: $codebook32Size\n"; 301 | print " Codebook16 count: $codebook16Size\n"; 302 | 303 | if ( $methodFlagsShift < 30 ) { 304 | $methodFlagsData .= pack("N",$methodFlagsCurrentLongWord); 305 | } 306 | 307 | if ( $codebooksFill ) { 308 | $codebook32Data .= chr(0x00) x ( 4 * ( 256 - $codebook32Size ) ); 309 | $codebook32Size = 256; 310 | } 311 | 312 | if ( $codebooksFill ) { 313 | $codebook16Data .= chr(0x00) x ( 2 * ( 256 - $codebook16Size ) ); 314 | $codebook16Size = 256; 315 | } 316 | 317 | my $frameEncodedFile = sprintf("%s%5.5d.bin",$frameEncodedPrefix,$frameIndex); 318 | my $frameEncoded = ''; 319 | $frameEncoded .= pack("N",$codebook32Size*4) . $codebook32Data; 320 | $frameEncoded .= pack("N",$codebook16Size*2) . $codebook16Data; 321 | $frameEncoded .= $methodFlagsData; 322 | $frameEncoded .= $vectorData; 323 | 324 | open( FRAME, '>'.$frameEncodedFile ) or die "Cannot write $frameEncodedFile\n"; 325 | print FRAME $frameEncoded; 326 | close FRAME; 327 | 328 | $frameIndex += 1; 329 | $tileDataLast2 = $tileDataLast; 330 | $tileDataLast = $tileData; 331 | } 332 | 333 | sub Help { 334 | die ' 335 | scdcinepakencodeframe [options] 336 | 337 | [description] 338 | takes the tiledata and encodes it using Cinepak for Sega and outputs 339 | sequentially named cinepaktiledata*.bin files 340 | 341 | [options] 342 | -codebooksfill fill the codebooks so always have 256 entries 343 | '; 344 | } 345 | -------------------------------------------------------------------------------- /scdimgvdppalette: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | # convert images to VDP friendly images for megadrive/megacd development 20 | ############################################################################### 21 | 22 | # TODO more verbosity... 23 | 24 | use strict; 25 | use warnings; 26 | use Image::Magick; 27 | 28 | use FindBin; 29 | use lib $FindBin::Bin; 30 | use SCDTools::Palette; 31 | 32 | my $palette = SCDTools::Palette->new(); 33 | 34 | if ( $#ARGV < 0 ) { 35 | &Help(); 36 | } 37 | 38 | my $verbosity = 2; 39 | 40 | my @imgFiles; 41 | 42 | my $resizeWidth = 0; 43 | my $resizeHeight = 0; 44 | my $resizeKeepAspect = 0; 45 | my $resizeToTiles = 0; 46 | my $trim = 0; 47 | my $ditherOrdered = ''; 48 | my $ditherVdp = 'fs'; 49 | my $ditherQuantize = 'fs'; 50 | my $ditherFinal = 'fs'; 51 | # recommended to be log2(colors), and going bigger to 8 doesn't seem to effect 52 | # final image but drastically lengthen the time to run 53 | my $treedepth = 4; 54 | my $debug = 0; 55 | 56 | my $colorCountMax = 0; 57 | 58 | foreach my $arg (@ARGV) { 59 | if ( $palette->ParseArg($arg) ) { 60 | # do nothing 61 | } elsif ( $arg =~ /^-resize=(\d+)x(\d+)$/i ) { 62 | $resizeWidth = $1; 63 | $resizeHeight = $2; 64 | } elsif ( $arg =~ /^-resizeKeepAspect$/i ) { 65 | $resizeKeepAspect = 1; 66 | } elsif ( $arg =~ /^-resizetotiles?$/i ) { 67 | $resizeToTiles = 1; 68 | } elsif ( $arg =~ /^-resizetoeventiles?$/i ) { 69 | $resizeToTiles = 2; 70 | } elsif ( $arg =~ /^-dither=(2x2|4x2|2x4|4x4|8x8)$/i ) { 71 | $ditherOrdered = $1; 72 | $ditherVdp = 'none'; 73 | $ditherQuantize = 'none'; 74 | $ditherFinal = 'none'; 75 | } elsif ( $arg =~ /^-dither=(none|r|fs)$/i ) { 76 | $ditherVdp = lc($1); 77 | $ditherQuantize = lc($1); 78 | $ditherFinal = lc($1); 79 | } elsif ( $arg =~ /^-dithervdp=(none|r|fs)$/i ) { 80 | $ditherVdp = lc($1); 81 | } elsif ( $arg =~ /^-ditherquantize=(none|r|fs)$/i ) { 82 | $ditherQuantize = lc($1); 83 | } elsif ( $arg =~ /^-ditherfinal=(none|r|fs)$/i ) { 84 | $ditherFinal = lc($1); 85 | } elsif ( $arg =~ /^-maxcolors=(\d+)$/i ) { 86 | $colorCountMax = $1; 87 | } elsif ( $arg =~ /^-trim$/i ) { 88 | $trim = 1; 89 | } elsif ( $arg =~ /^-debug$/i ) { 90 | $debug = 1; 91 | } elsif ( -e $arg ) { 92 | push @imgFiles, $arg; 93 | } else { 94 | print STDERR "\nCould not parse argument: $arg\n"; 95 | &Help(); 96 | } 97 | } 98 | 99 | $palette->ReadPalette(); 100 | $palette->SetPaletteCount(512/15); 101 | 102 | if ( $colorCountMax <= 0 ) { 103 | $colorCountMax = $palette->GetColorsPerPalette(); 104 | } 105 | 106 | foreach my $imgFile (@imgFiles) { 107 | &ImgExtractColors($imgFile); 108 | } 109 | 110 | 111 | 112 | ############################################################################### 113 | 114 | 115 | sub ImgExtractColors($) { 116 | my ($imgFile) = @_; 117 | 118 | my $imgOriginal = Image::Magick->new(); 119 | my $x = $imgOriginal->ReadImage($imgFile); 120 | warn $x if $x; 121 | #$imgOriginal->Set(alpha=>"Off"); 122 | 123 | #my $imgAlpha = $imgOriginal->Separate(channel=>'Alpha'); 124 | 125 | if ( $trim ) { 126 | $imgOriginal->Trim(); 127 | } 128 | 129 | if ( $resizeWidth && $resizeHeight ) { 130 | my $width = $imgOriginal->Get('width'); 131 | my $height = $imgOriginal->Get('height'); 132 | my $widthNew = $resizeWidth; 133 | my $heightNew = $resizeHeight; 134 | if ( $resizeKeepAspect ) { 135 | if ( $width * $resizeHeight > $height * $resizeWidth ) { 136 | $heightNew = int( ( $height * $resizeWidth / $width ) + .5 ); 137 | } elsif ( $width * $resizeHeight < $height * $resizeWidth ) { 138 | $widthNew = int( ( $width * $resizeHeight / $height ) + .5 ); 139 | } 140 | } 141 | # possible filters: Point, Box, Triangle, Hermite, Hanning, Hamming, Blackman, Gaussian, Quadratic, Cubic, Catrom, Mitchell, Lanczos, Bessel, Sinc 142 | $imgOriginal->Resize('width'=>$widthNew,'height'=>$heightNew,'filter'=>'Cubic'); 143 | if ( $resizeWidth != $widthNew || $resizeHeight != $heightNew ) { 144 | my $x = (($resizeWidth-$widthNew)>>1); 145 | my $y = (($resizeHeight-$heightNew)>>1); 146 | $imgOriginal->Extent('width'=>$resizeWidth,'height'=>$resizeHeight,'background'=>'rgb(0,0,0)'); 147 | $imgOriginal->Roll('x'=>$x,'y'=>$y); 148 | } 149 | } 150 | 151 | if ( $resizeToTiles ) { 152 | my $width = $imgOriginal->Get('width'); 153 | my $height = $imgOriginal->Get('height'); 154 | my $boundary = $resizeToTiles*8; 155 | if ( $width % $boundary != 0 || $height % $boundary != 0 ) { 156 | my $widthNew = int(($width+$boundary-1)/$boundary) * $boundary; 157 | my $heightNew = int(($height+$boundary-1)/$boundary) * $boundary; 158 | my $x = (($widthNew-$width)>>1); 159 | my $y = (($heightNew-$height)>>1); 160 | # offsets don't work with newer versions of image magick for extent 161 | #$imgOriginal->Extent('width'=>$widthNew,'height'=>$heightNew,'x'=>$x,'y'=>$y,'background'=>'rgb(0,0,0)'); 162 | #$imgOriginal->Extent('geometry'=>"${widthNew}x${heightNew}+${x}+${y}",'background'=>'rgb(0,0,0)'); 163 | if ( $widthNew != $width || $heightNew != $height ) { 164 | # so instead we can extent and roll 165 | $imgOriginal->Extent('width'=>$widthNew,'height'=>$heightNew,'background'=>'rgb(0,0,0)'); 166 | $imgOriginal->Roll('x'=>$x,'y'=>$y); 167 | } 168 | } 169 | } 170 | 171 | if ( $ditherOrdered ne '' ) { 172 | my $width = $imgOriginal->Get('width'); 173 | my $height = $imgOriginal->Get('height'); 174 | for ( my $y = 0; $y < $height; $y++ ) { 175 | for ( my $x = 0; $x < $width; $x++ ) { 176 | my @colors = $imgOriginal->GetPixel('channel'=>'RGB','normalize'=>1,'x'=>$x,'y'=>$y); 177 | # normalize (/256) and force onto 3 bit color (/8) 178 | my $orderedDitherAdd = &SCDTools::Palette::GetOrderedDitherAdd($ditherOrdered,$x,$y)/2048.0; 179 | for ( my $c = 0; $c < 3; $c++ ) { 180 | $colors[$c] += $orderedDitherAdd; 181 | if ( $colors[$c] > 1 ) { 182 | $colors[$c] = 1; 183 | } 184 | } 185 | $imgOriginal->SetPixel('channel'=>'RGB','x'=>$x,'y'=>$y,'color'=>\@colors); 186 | } 187 | } 188 | } 189 | 190 | my $img = $imgOriginal->Clone(); 191 | 192 | if ( $palette->GetColorsCountRead() >= $colorCountMax ) { 193 | # palette read in already too big, make sure to remove extra colors 194 | $palette->SetMaxColorCount($colorCountMax); 195 | } else { 196 | $palette->Reset(); 197 | $palette->AddColorsFromImageMagickImage($img); 198 | } 199 | 200 | my $colorsLength = $palette->GetColorsCount(); 201 | 202 | my $imgPalette = Image::Magick->new(); 203 | $palette->UpdateImageMagickPalette($imgPalette); 204 | 205 | if ( $debug ) { 206 | my $file = 'scdimgvdppalette_debugpal0_'.$imgFile; 207 | print "Writing $file (VDP color palette for original image)\n"; 208 | $imgPalette->Write($file); 209 | } 210 | 211 | if ( $colorsLength > $colorCountMax ) { 212 | if ( $ditherVdp eq 'none' ) { 213 | $img->Remap('image'=>$imgPalette,dither=>'false'); 214 | } elsif ( $ditherVdp eq 'r' ) { 215 | $img->Remap('image'=>$imgPalette,dither=>'true','dither-method'=>'Riemersma'); 216 | } elsif ( $ditherVdp eq 'fs' ) { 217 | $img->Remap('image'=>$imgPalette,dither=>'true','dither-method'=>'Floyd-Steinberg'); 218 | } else { 219 | die "Bad dither final: $ditherVdp\n"; 220 | } 221 | 222 | if ( $debug ) { 223 | my $file = 'scdimgvdppalette_debugimg0_'.$imgFile; 224 | print "Writing $file (mapped to VDP colors, too many colors for single palette still)\n"; 225 | $img->Write($file); 226 | } 227 | 228 | undef $imgPalette; 229 | 230 | $img = $imgOriginal->Clone(); 231 | 232 | if ( $ditherQuantize eq 'none' ) { 233 | $img->Quantize('colors'=>$colorCountMax,'measure_error'=>'true','treedepth'=>$treedepth,'dither'=>'false'); 234 | } elsif ( $ditherQuantize eq 'r' ) { 235 | $img->Quantize('colors'=>$colorCountMax,'measure_error'=>'true','treedepth'=>$treedepth,'dither'=>'true','dither-method'=>'Riemersma'); 236 | } elsif ( $ditherQuantize eq 'fs' ) { 237 | $img->Quantize('colors'=>$colorCountMax,'measure_error'=>'true','treedepth'=>$treedepth,'dither'=>'true','dither-method'=>'Floyd-Steinberg'); 238 | } else { 239 | die "Bad dither final: $ditherQuantize\n"; 240 | } 241 | 242 | if ( $debug ) { 243 | my $file = 'scdimgvdppalette_debugimg1_'.$imgFile; 244 | print "Writing $file (quantized to $colorCountMax VDP colors)\n"; 245 | $img->Write($file); 246 | } 247 | 248 | $palette->Reset(); 249 | $palette->AddColorsFromImageMagickImage($img); 250 | $colorsLength = $palette->GetColorsCount(); 251 | 252 | # quantization got less than desired amount of colors 253 | # add in the most used ones that are missing 254 | if ( $colorsLength < $colorCountMax ) { 255 | # add in all the colors then trim to desired amount of colors 256 | $palette->AddColorsFromImageMagickImage($imgOriginal); 257 | $palette->SetMaxColorCount($colorCountMax); 258 | } 259 | 260 | $colorsLength = $palette->GetColorsCount(); 261 | 262 | if ( $colorsLength > $colorCountMax ) { 263 | print STDERR "Quantization went beyond color count\n"; 264 | $palette->SetMaxColorCount($colorCountMax); 265 | } 266 | 267 | $colorsLength = $palette->GetColorsCount(); 268 | 269 | print "Quantization resulted in $colorsLength VDP colors\n"; 270 | 271 | $imgPalette = Image::Magick->new(); 272 | $palette->UpdateImageMagickPalette($imgPalette); 273 | 274 | if ( $debug ) { 275 | my $file = 'scdimgvdppalette_debugpal1_'.$imgFile; 276 | print "Writing $file (VDP color palette after quantization)\n"; 277 | $imgPalette->Write($file); 278 | } 279 | $palette->OutputPalette(); 280 | 281 | $img = $imgOriginal->Clone(); 282 | } elsif ( $palette->GetColorsCountRead() != $palette->GetColorsCount() ) { 283 | print "Image only has $colorsLength VDP colors\n"; 284 | } 285 | 286 | print "$ditherFinal\n"; 287 | if ( $ditherFinal eq 'none' ) { 288 | $img->Remap('image'=>$imgPalette,dither=>'false'); 289 | } elsif ( $ditherFinal eq 'r' ) { 290 | $img->Remap('image'=>$imgPalette,dither=>'true','dither-method'=>'Riemersma'); 291 | } elsif ( $ditherFinal eq 'fs' ) { 292 | $img->Remap('image'=>$imgPalette,dither=>'true','dither-method'=>'Floyd-Steinberg'); 293 | } else { 294 | die "Bad dither final: $ditherFinal\n"; 295 | } 296 | 297 | #$img->Composite(image=>$imgOriginal,compose=>'CopyOpacity'); 298 | $img->Composite(image=>$imgOriginal,compose=>'DstIn'); 299 | 300 | { 301 | my $file = 'scdimgvdppalette_'.$imgFile; 302 | if ( $debug ) { 303 | print "Writing $file (original image dithered to quatized colors)\n"; 304 | } 305 | $img->Write($file); 306 | } 307 | } 308 | 309 | sub Help { 310 | die ' 311 | scdimgvdppalette [options] 312 | 313 | [description] 314 | Convert image to Sega VDP palette with dithering/quantization. 315 | It is suggested to avoid transparency since they can become partially 316 | transparent in the process and typically result in ugly edges. 317 | Still a work in progress. 318 | 319 | '.$palette->GetHelpString().'[options] 320 | -maxcolors=<#> specify max colors (default 15) 321 | -trim trims outside of image 322 | -resize=x resize to a specific size 323 | -resizekeepaspect keep aspect for -resize= 324 | -resizetotiles resize the image to a tile boundary 325 | (centered and uses black for pixel fill) 326 | -resizetoeventiles resize the image to an even tile boundary 327 | (centered and uses black for pixel fill) 328 | 329 | [dither options] 330 | -dither= set all dithering 331 | -dithervdp= set dithering of palette to VDP colors 332 | -ditherquantize= set dithering of palette quantization 333 | -ditherfinal= set dithering of final image 334 | none - no dithering 335 | r - Riemersma dithering 336 | fs - Floyd-Steinberg dithering (default) 337 | 2x2 - ordered 2x2 338 | 4x2 - ordered 4x2 339 | 4x4 - ordered 4x4 340 | 341 | '; 342 | } 343 | -------------------------------------------------------------------------------- /scdasmall: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | # assemble the assembly with each compiler and make sure it produces the 20 | # same binary (looking for fully optimized binaries) 21 | ############################################################################### 22 | 23 | use strict; 24 | use warnings; 25 | 26 | # assembler path names 27 | # for those running natively can use short name if assembler is in your path 28 | # Which($) allows short names for wine/dosbox executables in your path 29 | 30 | my $asmx = &Which('asmx'); 31 | 32 | my $z80 = 0; 33 | my $cleanup = 1; 34 | 35 | # 68k only assemblers 36 | my $asm68k = &Which('asm68k.exe'); 37 | my $snasm68k = &Which('SNASM68K.EXE'); 38 | my $asl = &Which('asl'); 39 | my $vasmm68k_mot = &Which('vasmm68k_mot'); 40 | my $gas68kelf_as = &Which('m68k-elf-as'); 41 | my $gas68kelf_ld = &Which('m68k-elf-ld'); 42 | if ( $gas68kelf_ld eq '' ) { 43 | $gas68kelf_as = ''; 44 | } 45 | 46 | # z80 only assemblers 47 | my $z80asm = &Which('z80asm'); 48 | my $pasmo = &Which('pasmo'); 49 | my $vasmz80_oldstyle = &Which('vasmz80_oldstyle'); 50 | my $tasm = &Which('TASM.EXE'); 51 | my $sjasm = &Which('sjasm'); 52 | my $gasz80coff_as = &Which('z80-unknown-coff-as'); 53 | my $gasz80coff_ld = &Which('z80-unknown-coff-ld'); 54 | if ( $gasz80coff_ld eq '' ) { 55 | $gasz80coff_as = ''; 56 | } 57 | 58 | # used for win/dos executables 59 | my $wine = &Which('wine'); 60 | my $dosbox = &Which('dosbox'); 61 | 62 | #my $asm68kopts = '/o op+ /o os+ /o ow+ /o oz+ /o oaq+ /o osq+ /o omq+'; 63 | my $asm68kopts = '/o op+ /o os+ /o ow+ /o oz+ '; 64 | #my $snasm68kopts = '-o op+ -o os+ -o ow+ -o oz+ -o oaq+ -o osq+ -o omq+'; 65 | my $snasm68kopts = '-o op+ -o os+ -o ow+ -o oz+'; 66 | 67 | my $vasmopts68k = ''; 68 | 69 | #op- Enable PC relative optimizations. Switch to PC relative addressing when absolute long addressing is used and the code allows such a switch. 70 | #os- Enable short branch optimizations. Backwards relative branches will use the short form if possible. 71 | #ow- Enable absolute word addressing optimizations. If absolute long addressing is specified, but the address will fit in a word, the shorter form is used. Optimization is not made if the size is specified. 72 | #oz- Enable zero displacement (offset-zero) optimizations. If an instruction uses the Indirect Addressing with Displacement addressing mode and the displacement is zero, the instruction will be assembled to Indirect Addressing mode. 73 | #oaq- Enable ADDQ optimizations. ADD instructions that can be coded as ADDQ instructions will be assembled as ADDQ instructions. 74 | #osq- Enable SUBQ optimizations. Like above. 75 | 76 | # just the short file name 77 | my $snasm68kShort = $snasm68k; 78 | $snasm68kShort =~ s/^(.*[\\\/])//g; 79 | 80 | my $asm68kShort = $asm68k; 81 | $asm68kShort =~ s/^(.*[\\\/])//g; 82 | 83 | my $tasmShort = $tasm; 84 | $tasmShort =~ s/^(.*[\\\/])//g; 85 | 86 | my @files; 87 | 88 | foreach my $arg (@ARGV) { 89 | if ( $arg =~ m/^-(68k|68000)$/i ) { 90 | $z80 = 0; 91 | } elsif ( $arg =~ m/^-z80$/i ) { 92 | $z80 = 1; 93 | } elsif ( $arg =~ m/^-nocleanup$/i ) { 94 | $cleanup = 0; 95 | } elsif ( $arg =~ /-asm68kopts=(.*)$/ ) { 96 | $asm68kopts = $1; 97 | } elsif ( $arg =~ /-snasm68kopts=(.*)$/ ) { 98 | $snasm68kopts = $1; 99 | } elsif ( $arg eq '-unopt' ) { 100 | $asm68kopts = ''; 101 | $snasm68kopts = ''; 102 | $vasmopts68k = '-no-opt' 103 | } elsif ( -e $arg ) { 104 | push @files, $arg; 105 | } else { 106 | print STDERR "\nCould not parse argument: $arg\n"; 107 | &Help(); 108 | } 109 | } 110 | 111 | if ( $#files != 0 && $#files != 1 ) { 112 | &Help(); 113 | } 114 | 115 | &Clean(); 116 | 117 | my $asm = $files[0]; 118 | my $target = $#files == 1 ? $files[1] : 'asmx.bin'; 119 | 120 | # baseline sure still works with original asmx 121 | if ( $asmx ne '' ) { 122 | &Running('asmx'); 123 | if ( $z80 ) { 124 | system("$asmx -C z80 -b 0 -e -w -o asmx.bin -- $asm"); 125 | } else { 126 | system("$asmx -C 68000 -b 0 -e -w -o asmx.bin -- $asm"); 127 | } 128 | } 129 | 130 | if ( $asl ne '' ) { 131 | &Running('asl'); 132 | if ( open(TMPASM, ">asl.asm") ) { 133 | print TMPASM " 134 | incbin macro file 135 | binclude file 136 | endm 137 | even macro 138 | align 2 139 | endm 140 | 141 | include $asm 142 | "; 143 | } 144 | close TMPASM; 145 | my $cpu = $z80 ? 'z80' : '68000'; 146 | system("asl -cpu $cpu -xx -a -A asl.asm -o asl.p -L -olist asl.lst -E asl.err"); 147 | # note: p2bin is released as part of asl 148 | # -r $-$ means min to max addresses, need to \\ for perl and \$ for perl 149 | # to convert to \$ so shell doesn't interpret $ 150 | system("p2bin -r \\\$-\\\$ asl.p asl.bin "); 151 | } 152 | 153 | if ( ! $z80 && $vasmm68k_mot ne '' ) { 154 | &Running('vasmm68k_mot'); 155 | system("vasmm68k_mot $asm -Fbin -m68000 $vasmopts68k -o vasmm68k.bin"); 156 | } 157 | 158 | if ( $z80 && $vasmz80_oldstyle ne '' ) { 159 | &Running('vasmz80_oldstyle'); 160 | system("vasmz80_oldstyle $asm -Fbin -o vasmz80.bin"); 161 | } 162 | 163 | if ( ! $z80 && $gas68kelf_as ne '' ) { 164 | &Running('gas68kelf --mri'); 165 | system("echo 'BASE 0' > gas68k.mri"); 166 | system("$gas68kelf_as -m68000 --mri -o gas68kmri.o $asm"); 167 | system("$gas68kelf_ld -c gas68k.mri -nostdlib --oformat binary -o gas68kmri.bin gas68kmri.o"); 168 | &Running('gas68kelf'); 169 | system("echo 'BASE 0' > gas68k.mri"); 170 | system("$gas68kelf_as -m68000 -o gas68k.o $asm"); 171 | system("$gas68kelf_ld -c gas68k.mri -nostdlib --oformat binary -o gas68k.bin gas68k.o"); 172 | } 173 | 174 | if ( $z80 && $gasz80coff_as ne '' ) { 175 | &Running('gasz80coff'); 176 | system("$gasz80coff_as -o gasz80.o $asm"); 177 | system("$gasz80coff_ld -nostdlib --oformat binary -o gasz80.bin gasz80.o"); 178 | } 179 | 180 | if ( ! $z80 && $asm68k ne '' ) { 181 | # wine runs fine, so don't need dosbox 182 | #print("wine $asm68k /k /p /o w+ $asm68kopts $asm, asm68k.bin\n"); 183 | # doesn't work on dosbox since Win32 exe 184 | if ( $wine ne '' ) { 185 | &Running('asm68k'); 186 | system("wine $asm68k /k /p /o w+ $asm68kopts $asm, asm68k.bin"); 187 | } else { 188 | $asm68k = ''; 189 | } 190 | } 191 | 192 | if ( ! $z80 && $snasm68k ne '' ) { 193 | if ( $dosbox ne '' ) { 194 | &Running('snasm68k'); 195 | # wine can't run, so need to make a bat file to run command with options 196 | # copy to local directory so that local directory is mounted 197 | system("cp $snasm68k ."); 198 | # listing file takes forever on large assemblies 199 | # system("echo '$snasm68kShort -k -p -o w+ $snasm68kopts $asm, SNASM68K.BIN, SNASM68K.MAP, SNASM68K.LST > SNASM68K.OUT' > SNASM68K.BAT"); 200 | # -o w+ 201 | system("echo '$snasm68kShort -k -p -o w- $snasm68kopts $asm, SNASM68K.BIN > SNASM68K.OUT' > SNASM68K.BAT"); 202 | system("dosbox SNASM68K.BAT -exit"); 203 | } else { 204 | $snasm68k = ''; 205 | } 206 | } 207 | 208 | if ( $z80 && $z80asm ne '' ) { 209 | &Running('z80asm'); 210 | system("z80asm $asm --output=z80asm.bin"); 211 | } 212 | 213 | if ( $z80 && $pasmo ne '' ) { 214 | &Running('pasmo'); 215 | system("pasmo $asm pasmo.bin"); 216 | } 217 | 218 | if ( $z80 && $tasm ne '' ) { 219 | if ( $dosbox ne '' ) { 220 | &Running('tasm'); 221 | # wine can't run, so need to make a bat file to run command with options 222 | # copy to local directory so that local directory is mounted 223 | system("cp $tasm ."); 224 | my $tasm80 = $tasm; 225 | $tasm80 =~ s/TASM.EXE$/TASM80.TAB/; 226 | system("cp $tasm80 ."); 227 | # listing file takes forever on large assemblies 228 | # system("echo '$snasm68kShort -k -p -o w+ $snasm68kopts $asm, SNASM68K.BIN, SNASM68K.MAP, SNASM68K.LST > SNASM68K.OUT' > SNASM68K.BAT"); 229 | # -o w+ 230 | system("echo '$tasmShort -80 -b $asm TASM.BIN > TASM.OUT' > TASM.BAT"); 231 | system("dosbox TASM.BAT -exit"); 232 | } else { 233 | $tasm = ''; 234 | } 235 | } 236 | 237 | if ( $z80 && $sjasm ne '' ) { 238 | &Running('sjasm'); 239 | system("sjasm $asm sjasm.bin"); 240 | } 241 | 242 | print "\n"; 243 | 244 | my $rc0 = &Compare( 1,'asmx', $asmx, $target,'asmx.bin'); 245 | my $rc1 = &Compare( 1,'asl', $asl, $target,'asl.bin'); 246 | my $rc2 = &Compare(!$z80,'vasmm68k_mot', $vasmm68k_mot, $target,'vasmm68k.bin'); 247 | my $rc3 = &Compare( $z80,'vasmz80_oldstyle',$vasmz80_oldstyle,$target,'vasmz80.bin'); 248 | my $rc4 = &Compare(!$z80,'gas68kelf_mri', $gas68kelf_as, $target,'gas68kmri.bin'); 249 | my $rc5 = &Compare(!$z80,'gas68kelf', $gas68kelf_as, $target,'gas68k.bin'); 250 | my $rc6 = &Compare( $z80,'gasz80coff', $gasz80coff_as, $target,'gasz80.bin'); 251 | my $rc7 = &Compare(!$z80,'asm68k', $asm68k, $target,'asm68k.bin'); 252 | my $rc8 = &Compare(!$z80,'snasm68k', $snasm68k, $target,'SNASM68K.BIN'); 253 | my $rc9 = &Compare( $z80,'z80asm', $z80asm, $target,'z80asm.bin'); 254 | my $rcA = &Compare( $z80,'pasmo', $pasmo, $target,'pasmo.bin'); 255 | my $rcB = &Compare( $z80,'tasm', $tasm, $target,'TASM.BIN'); 256 | my $rcC = &Compare( $z80,'sjasm', $sjasm, $target,'sjasm.bin'); 257 | 258 | # see if clean cmps, if so clean up files and report it was clean 259 | if ( $rc0 && $rc1 && $rc2 && $rc3 && $rc4 && $rc5 && $rc6 && $rc7 && $rc8 && $rc9 && $rcA && $rcB && $rcC ) { 260 | if ( $cleanup ) { 261 | &Clean(); 262 | } 263 | print "scdasmall success: all clean\n"; 264 | } 265 | 266 | print "\n"; 267 | 268 | 269 | 270 | ############################################################################### 271 | 272 | 273 | 274 | sub Compare { 275 | my ($used,$toolName,$tool,$bin0,$bin1) = @_; 276 | my $rc = 1; 277 | if ( $used && $tool ne '' ) { 278 | if ( ! -e $bin0 ) { 279 | print STDERR "scdasmall failure for $toolName: did not make $bin0\n"; 280 | $rc = 0; 281 | } 282 | if ( ! -e $bin1 ) { 283 | print STDERR "scdasmall failure for $toolName: did not make $bin1\n"; 284 | $rc = 0; 285 | } 286 | if ( $rc ) { 287 | if ( system("cmp -s $bin0 $bin1") ) { 288 | print STDERR "scdasmall failure for $toolName: difference between $bin0 $bin1\n"; 289 | $rc = 0; 290 | } 291 | } 292 | } 293 | return $rc; 294 | } 295 | 296 | sub Running { 297 | print (('='x79)."\n".$_[0]."\n".('='x79)."\n"); 298 | } 299 | 300 | 301 | sub Clean { 302 | if ( $asmx ne '' ) { 303 | system("rm -f asmx.bin"); 304 | } 305 | if ( $asl ne '' ) { 306 | system("rm -f asl.asm"); 307 | system("rm -f asl.p"); 308 | system("rm -f asl.bin"); 309 | system("rm -f asl.inc"); 310 | system("rm -f asl.lst"); 311 | system("rm -f asl.err"); 312 | } 313 | if ( ! $z80 && $vasmm68k_mot ) { 314 | system("rm -f vasmm68k.bin"); 315 | } 316 | if ( $z80 && $vasmz80_oldstyle ) { 317 | system("rm -f vasmz80.bin"); 318 | } 319 | if ( ! $z80 && $gas68kelf_as ) { 320 | system("rm -f gas68k.mri"); 321 | system("rm -f gas68k.o"); 322 | system("rm -f gas68k.bin"); 323 | } 324 | if ( $z80 && $gasz80coff_as ) { 325 | system("rm -f gasz80.o"); 326 | system("rm -f gasz80.bin"); 327 | } 328 | if ( ! $z80 && $asm68k ne '' ) { 329 | system("rm -f asm68k.bin"); 330 | } 331 | if ( ! $z80 && $snasm68k ne '' ) { 332 | system("rm -f $snasm68kShort"); 333 | system("rm -f SNASM68K.BAT"); 334 | system("rm -f SNASM68K.OUT"); 335 | system("rm -f SNASM68K.BIN"); 336 | system("rm -f SNASM68K.MAP"); 337 | system("rm -f SNASM68K.LST"); 338 | } 339 | if ( $z80 && $z80asm ne '' ) { 340 | system("rm -f z80asm.bin"); 341 | } 342 | if ( $z80 && $pasmo ne '' ) { 343 | system("rm -f pasmo.bin"); 344 | } 345 | if ( $z80 && $tasm ne '' ) { 346 | system("rm -f $tasmShort"); 347 | system("rm -f TASM.BAT"); 348 | system("rm -f TASM.OUT"); 349 | system("rm -f TASM.BIN"); 350 | system("rm -f TASM.MAP"); 351 | system("rm -f TASM.LST"); 352 | } 353 | if ( $z80 && $sjasm ne '' ) { 354 | system("rm -f sjasm.bin"); 355 | } 356 | } 357 | 358 | sub Which($) { 359 | my ($file) = @_; 360 | my $value = `which $file 2> /dev/null`; 361 | chomp $value; 362 | return $value; 363 | } 364 | 365 | sub Help { 366 | die ' 367 | scdasmall [options] [] 368 | 369 | [description] 370 | ensure several assemblers all have the same binary output for an asmfile 371 | 372 | [supported assemblers] 373 | [68k] 374 | asl 375 | asmx 376 | vasmm68k_mot 377 | m68k-elf-* (gas) 378 | SNASM68K (dosbox) 379 | asm68k (wine) 380 | [z80] 381 | asmx 382 | pasmo 383 | sjasm 384 | vasmz80_oldstyle 385 | z80asm 386 | z80-unknown-coff-* (gas) 387 | tasm (dosbox) 388 | 389 | [options] 390 | -68k specify 68k assembling (default) 391 | -z80 specify z80 assembling 392 | -asm68kopts= opts to pass to asm68k 393 | -snasm68kopts= opts to pass to snasm68k 394 | -unopt do not send optimization opts to assemblers 395 | -nocleanup do not clean up successful assembles (default is to clean) 396 | 397 | file to assemble 398 | [] optional file to compare against (defaults to asmx.bin) 399 | 400 | '; 401 | } 402 | -------------------------------------------------------------------------------- /scdcinepakencode: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ############################################################################### 3 | # Copyright (c) 2011 by bgvanbur 4 | # 5 | # This program is free software; you can redistribute it and/or modify it 6 | # under the terms of the GNU General Public License as published by the 7 | # Free Software Foundation; either version 2 of the License, or (at your 8 | # option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, but 11 | # WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License along 16 | # with this program; if not, write to the Free Software Foundation, Inc., 17 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 | ############################################################################### 19 | # makes Ecco 2's MV001.CIN 97% of the original size 20 | # makes Star Wars Chess's X6YO_ST.SEG 45% of the original size 21 | # TODO (44% once frame skip works) 22 | ############################################################################### 23 | 24 | use strict; 25 | use warnings; 26 | 27 | if ( $#ARGV < 0 ) { 28 | &Help(); 29 | } 30 | 31 | my $cinepakWidth = 32*8; 32 | my $cinepakHeight = 14*8; 33 | my $cinepakIdentifier = ''; 34 | my $cinepakBaseRate = 600; 35 | 36 | my $isEcco32x = 0; 37 | 38 | my $cinepakFrameDuration = 75; 39 | 40 | # all known commerical cinepak videos have at least 2 palettes 41 | # partially implemented but causes tile data corruption with original decoder 42 | my $cinepakForceAtLeastTwoPalettes = 1; 43 | 44 | # TODO still need calculate frame time before skipped frame before should be enabled 45 | my $optimizeSkipUnchangedFramesIfPossible = 0; 46 | 47 | # the PCM FD value set in the SUBPLAY.BIN (default is 0x0400) 48 | my $pcmFD = 0x0400; 49 | 50 | my $pcmFile = ''; 51 | # not the actual play rate, 52 | # but the rate the SUBPLAY.BIN code thinks it is playing at (V1.2 thinks 16000) 53 | my $pcmDataRate = 16000; 54 | 55 | my $pcmFramePrefix = 'pcmchunk'; 56 | 57 | my $customEncodingFile = ''; 58 | # TODO can remove single palette for -paldatas= 59 | my $singlePalette = ''; 60 | my $paldatasString = 'paldata*.bin'; 61 | my $palmapsString = 'palmap*.bin'; 62 | my $cinepaktiledatasString = 'cinepaktiledata*.bin'; 63 | 64 | # parse args 65 | foreach my $arg (@ARGV) { 66 | if ( $arg =~ /^-width=(\d+)$/i ) { 67 | $cinepakWidth = $1; 68 | } elsif ( $arg =~ /^-height=(\d+)$/i ) { 69 | $cinepakHeight = $1; 70 | } elsif ( $arg =~ /^-size=(\d+)x(\d+)$/i ) { 71 | $cinepakWidth = $1; 72 | $cinepakHeight = $2; 73 | } elsif ( $arg =~ /^-id=(.{4})$/i ) { 74 | $cinepakIdentifier = $1; 75 | } elsif ( $arg =~ /^-baserate=(\d+)$/i ) { 76 | $cinepakBaseRate = $1; 77 | } elsif ( $arg =~ /^-frameduration=(.+)$/i ) { 78 | $cinepakFrameDuration = $1; 79 | } elsif ( $arg =~ /^-fps=(.+)$/i ) { 80 | my $fps = $1; 81 | $cinepakFrameDuration = $cinepakBaseRate/$fps*(12500000/384.0*($pcmFD/2048.0))/$pcmDataRate; 82 | } elsif ( $arg =~ /^-custom=(.+)$/i ) { 83 | $customEncodingFile = $1; 84 | } elsif ( $arg =~ /^-pcmfile=(.+)$/i ) { 85 | $pcmFile = $1; 86 | } elsif ( $arg =~ /^-pcmfd=(\d+)$/i ) { 87 | $pcmFD = $1; 88 | } elsif ( $arg =~ /^-pcmrate=(.+)$/i ) { 89 | $pcmDataRate = $1; 90 | } elsif ( $arg =~ /^-singlepalette=(.+)$/i ) { 91 | $singlePalette = $1; 92 | } elsif ( $arg =~ /^-paldatas=(.+)$/i ) { 93 | $paldatasString = $1; 94 | } elsif ( $arg =~ /^-palmaps=(.+)$/i ) { 95 | $palmapsString = $1; 96 | } elsif ( $arg =~ /^-cinepaktiledatas=(.+)$/i ) { 97 | $cinepaktiledatasString = $1; 98 | } elsif ( $arg =~ /^-ecco32x$/i ) { 99 | $isEcco32x = 1; 100 | } else { 101 | print STDERR "\nCould not parse argument: $arg\n"; 102 | &Help(); 103 | } 104 | } 105 | 106 | ############################################################################### 107 | 108 | if ( $cinepakIdentifier eq '' ) { 109 | if ( $isEcco32x ) { 110 | $cinepakIdentifier = 'cvid'; 111 | } else { 112 | $cinepakIdentifier = 'SEGA'; 113 | } 114 | } 115 | 116 | my $cinepakSampleTable = ''; 117 | my $cinepakSampleData = ''; 118 | 119 | my $pcmFrameSize = 0x4000; 120 | 121 | my $pcmFrameIndex = 0; 122 | my @pcmFrameFiles; 123 | 124 | # used to potentially skip frames, need to make sure palettes don't change 125 | # if we want to skip a frame 126 | my $imgPaletteLast = ''; 127 | my $imgPaletteMapLast = ''; 128 | 129 | my $pcmFileSize = 0; 130 | if ( $pcmFile ne '' ) { 131 | $pcmFileSize = -s $pcmFile; 132 | } 133 | 134 | # empty pcm file means no audio 135 | if ( $pcmFileSize > 0 ) { 136 | open( PCM, '<'.$pcmFile ) or die "Cannot read $pcmFile\n"; 137 | 138 | for ( my $pcmFileIndex = 0; $pcmFileIndex < $pcmFileSize; $pcmFileIndex += $pcmFrameSize ) { 139 | my $pcmFrameSizeCurrent = $pcmFileSize - $pcmFileIndex; 140 | if ( $pcmFrameSizeCurrent > $pcmFrameSize ) { 141 | $pcmFrameSizeCurrent = $pcmFrameSize; 142 | } 143 | 144 | my $pcmFrameData = ''; 145 | if ( read(PCM, $pcmFrameData, $pcmFrameSizeCurrent ) != $pcmFrameSizeCurrent ) { 146 | die "Cannot read from pcm file as expected\n"; 147 | } 148 | 149 | my $pcmFrameFile = sprintf("%s%5.5d.pcm",$pcmFramePrefix,$pcmFrameIndex); 150 | $pcmFrameIndex += 1; 151 | push @pcmFrameFiles, $pcmFrameFile; 152 | 153 | open( PCMFRAME, '>'.$pcmFrameFile ) or die "Cannot write $pcmFrameFile\n"; 154 | print PCMFRAME $pcmFrameData; 155 | close PCMFRAME; 156 | } 157 | 158 | close PCM; 159 | } 160 | 161 | my $pcmFrameCount = $pcmFrameIndex; 162 | 163 | $pcmFrameIndex = 0; 164 | 165 | my $imgFrameIndex = 0; 166 | 167 | my $pcmTimeFinal = $cinepakBaseRate * $pcmFileSize / $pcmDataRate * $pcmFD / 0x0400; 168 | my $pcmTimeFrame = $cinepakBaseRate * $pcmFrameSize / $pcmDataRate * $pcmFD / 0x0400; 169 | 170 | my $pcmTimeCurrent = -0.4 * $pcmTimeFrame; 171 | 172 | my $imgTimeCurrent = 0; 173 | 174 | ############################################################################### 175 | 176 | if ( $customEncodingFile ne '' ) { 177 | my $customEval = ''; 178 | if ( open(CUSTOM,$customEncodingFile) ) { 179 | binmode CUSTOM; 180 | my $customEncodingFileSize = -s $customEncodingFile; 181 | read(CUSTOM,$customEval,$customEncodingFileSize); 182 | close CUSTOM; 183 | } 184 | eval($customEval); 185 | } else { 186 | my @paldatas = sort <${paldatasString}>; 187 | my @palmaps = sort <${palmapsString}>; 188 | my @cinepaktiledatas = sort <${cinepaktiledatasString}>; 189 | my $paldatasCount = $#paldatas+1; 190 | my $palmapsCount = $#palmaps+1; 191 | for ( my $i = 0; $i <= $#cinepaktiledatas; $i++ ) { 192 | if ( $singlePalette ) { 193 | &AddImgFrame($cinepakFrameDuration,$singlePalette,'',$cinepaktiledatas[$i]); 194 | } else { 195 | my $paldata = $i < $paldatasCount ? $paldatas[$i] : ''; 196 | my $palmap = $i < $palmapsCount ? $palmaps[$i] : ''; 197 | &AddImgFrame($cinepakFrameDuration,$paldata,$palmap,$cinepaktiledatas[$i]); 198 | } 199 | } 200 | } 201 | 202 | ############################################################################### 203 | 204 | print 205 | "FILMStart:\n". 206 | "\tdc.b\t'FILM'\n". 207 | "\tdc.l\t(FILMEnd-FILMStart)\n". 208 | "\tdc.l\t0\n". 209 | "\tdc.l\t0\n". 210 | "FDSCStart\n". 211 | "\tdc.b\t'FDSC'\n". 212 | "\tdc.l\t(FDSCEnd-FDSCStart)\n". 213 | "\tdc.b\t'$cinepakIdentifier'\n". 214 | "\tdc.l\t$cinepakHeight\n". 215 | "\tdc.l\t$cinepakWidth\n". 216 | "FDSCEnd:\n". 217 | "STABStart:\n". 218 | "\tdc.b\t'STAB'\n". 219 | "\tdc.l\t(STABEnd-STABStart)\n". 220 | "\tdc.l\t$cinepakBaseRate\n". 221 | "\tdc.l\t(STABSampleTableEnd-STABSampleTableStart)/16\n". 222 | "STABSampleTableStart:\n". 223 | $cinepakSampleTable. 224 | # TODO match with Ecco 2 with unused extra bytes 225 | #"\tdc.l\t0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0\n". 226 | #"\tdc.l\t0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0\n". 227 | "STABSampleTableEnd:\n". 228 | # TODO match with Ecco 32x with unused extra bytes 229 | "\tdc.l\t0,0,0,0\n". 230 | "STABEnd:\n". 231 | "FILMEnd:\n". 232 | "SampleDataStart:\n". 233 | $cinepakSampleData. 234 | "SampleDataEnd:\n"; 235 | 236 | 237 | 238 | 239 | ############################################################################### 240 | 241 | sub AddImgFrame { 242 | my ($imgDuration,$imgPalette,$imgPaletteMap,$imgMap) = @_; 243 | # TODO option for debug info for custom? 244 | if ( 0 ) { 245 | print STDERR "AddImgFrame($imgDuration,$imgPalette,$imgPaletteMap,$imgMap)\n"; 246 | } 247 | 248 | $imgDuration *= $pcmFD / 0x0400; 249 | 250 | while ( $pcmFrameIndex < $pcmFrameCount && 251 | $imgTimeCurrent > $pcmTimeCurrent ) { 252 | # add pcm frame 253 | my $pcmDataStart = "PCMData${pcmFrameIndex}Start"; 254 | my $pcmDataEnd = "PCMData${pcmFrameIndex}End"; 255 | my $pcmFrameFile = $pcmFrameFiles[$pcmFrameIndex]; 256 | $cinepakSampleTable .= 257 | "PCMEntry${pcmFrameIndex}:\n". 258 | "\tdc.l\t($pcmDataStart-SampleDataStart)\n". 259 | "\tdc.l\t($pcmDataEnd-$pcmDataStart)\n". 260 | "\tdc.l\t0xFFFFFFFF\n". 261 | "\tdc.l\t1\n"; 262 | $cinepakSampleData .= 263 | "$pcmDataStart:\n". 264 | "\tincbin\t$pcmFrameFile\n". 265 | "\teven\n". 266 | "$pcmDataEnd:\n"; 267 | $pcmFrameIndex += 1; 268 | $pcmTimeCurrent += $pcmTimeFrame; 269 | } 270 | 271 | my $imgDataStart = "ImgData${imgFrameIndex}Start"; 272 | my $imgDataEnd = "ImgData${imgFrameIndex}End"; 273 | my $imgTimeCurrentInt = int($imgTimeCurrent); 274 | my $imgDurationInt = int($imgTimeCurrent + $imgDuration) - $imgTimeCurrentInt; 275 | 276 | if ( $isEcco32x ) { 277 | $cinepakSampleTable .= 278 | "ImgEntry${imgFrameIndex}:\n". 279 | "\tdc.l\t($imgDataStart-SampleDataStart)\n". 280 | "\tdc.l\t($imgDataEnd-$imgDataStart)\n". 281 | "\tdc.l\t$imgTimeCurrentInt\n". 282 | # TODO does not correctly indicate value for skipped frames 283 | "\tdc.l\t$imgDurationInt\n"; 284 | $cinepakSampleData .= 285 | "$imgDataStart:\n". 286 | "\tincbin\t$imgMap\n". 287 | "$imgDataEnd:\n"; 288 | } else { 289 | # only skip frame if not custom and done with audio frames or don't need 290 | # image frame right before next audio frame 291 | my $addFrame = 1; 292 | # in case of single palette or missing palettes, keep using last palette 293 | if ( $imgPalette eq '' ) { 294 | $imgPalette = $imgPaletteLast; 295 | } 296 | if ( $imgPalette eq '' ) { 297 | die "Cannot handle unspecified palette\n"; 298 | } 299 | if ( $optimizeSkipUnchangedFramesIfPossible && 300 | $customEncodingFile eq '' && 301 | $imgPaletteLast ne '' && 302 | ( $pcmFrameIndex >= $pcmFrameCount || 303 | $imgTimeCurrent + $imgDuration + 1 < $pcmTimeCurrent ) ) { 304 | # ensure palettes are the same 305 | if ( &CompareFiles($imgPalette,$imgPaletteLast) ) { 306 | # ensure palette maps are the same 307 | if ( ( $imgPaletteMap eq '' && 308 | $imgPaletteMapLast eq '' ) || 309 | ( $imgPaletteMap ne '' && 310 | $imgPaletteMapLast ne '' && 311 | &CompareFiles($imgPaletteMap,$imgPaletteMapLast) ) ) { 312 | # ensure image map is all zeros 313 | # (zero codebook sizes, method map all zeros) 314 | if ( open( MAP, $imgMap ) ) { 315 | my $imgMapSize = -s $imgMap; 316 | my $imgMapData = ''; 317 | if ( read(MAP,$imgMapData,$imgMapSize) == $imgMapSize ) { 318 | if ( $imgMapData !~ /[\x01-\xFF]/ ) { 319 | $addFrame = 0; 320 | } 321 | } 322 | } 323 | close MAP; 324 | } 325 | } 326 | } 327 | if ( $addFrame ) { 328 | my $imgPaletteSize = -s $imgPalette; 329 | my $imgPaletteCount = $imgPaletteSize >> 5; 330 | my $imgPaletteMapSize = $imgPaletteCount > 1 ? -s $imgPaletteMap : 0; 331 | my $imgMapSize = 32 * $cinepakWidth/8 * $cinepakHeight/8; 332 | my $cinepakForceAtLeastTwoPalettesThisImage = 0; 333 | if ( $cinepakForceAtLeastTwoPalettes && 334 | $imgPaletteCount == 1 ) { 335 | $cinepakForceAtLeastTwoPalettesThisImage = 1; 336 | $imgPaletteCount = 2; 337 | $imgPaletteSize = 2*32; 338 | $imgPaletteMapSize = 4 * int( ( $cinepakWidth/8 * $cinepakHeight/8 + 15 ) / 16 ); 339 | } 340 | $cinepakSampleTable .= 341 | "ImgEntry${imgFrameIndex}:\n". 342 | "\tdc.l\t($imgDataStart-SampleDataStart)\n". 343 | "\tdc.l\t($imgDataEnd-$imgDataStart)\n". 344 | "\tdc.l\t$imgTimeCurrentInt\n". 345 | # TODO does not correctly indicate value for skipped frames 346 | "\tdc.l\t$imgDurationInt\n"; 347 | $cinepakSampleData .= 348 | "$imgDataStart:\n". 349 | "\tdc.b\t'SM',0x00,0x2".($imgPaletteCount-1)."\n". 350 | "\tdc.l\t".(12+$imgPaletteSize+$imgPaletteMapSize+$imgMapSize)."\n". 351 | "\tdc.w\t".($cinepakWidth/8)."\n". 352 | "\tdc.w\t".($cinepakHeight/8)."\n". 353 | "\tincbin\t$imgPalette\n"; 354 | 355 | if ( $cinepakForceAtLeastTwoPalettesThisImage ) { 356 | # zeroed extra palette 357 | $cinepakSampleData .= 358 | "\tdc.w\t0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0\n"; 359 | # zeroed palette map 360 | $cinepakSampleData .= 361 | "\tdc.l\t0".(",0"x($imgPaletteMapSize/4-1))."\n"; 362 | } elsif ( $imgPaletteCount > 1 ) { 363 | $cinepakSampleData .= 364 | "\tincbin\t$imgPaletteMap\n"; 365 | } 366 | $cinepakSampleData .= 367 | "\tincbin\t$imgMap\n". 368 | "$imgDataEnd:\n"; 369 | } else { 370 | $cinepakSampleTable .= 371 | "\t;; image frame skipped\n"; 372 | $cinepakSampleData .= 373 | "\t;; image frame skipped\n"; 374 | } 375 | } 376 | $imgPaletteLast = $imgPalette; 377 | $imgPaletteMapLast = $imgPaletteMap; 378 | $imgFrameIndex += 1; 379 | $imgTimeCurrent += $imgDuration; 380 | } 381 | 382 | sub CompareFiles { 383 | my ($file0,$file1) = @_; 384 | my $result = 0; 385 | if ( $file0 eq $file1 ) { 386 | $result = 1; 387 | } else { 388 | my $file0Size = -s $file0; 389 | my $file1Size = -s $file1; 390 | if ( $file0Size == $file1Size ) { 391 | if ( open(FILE0,$file0) ) { 392 | if ( open(FILE1,$file1) ) { 393 | my $file0Data = ''; 394 | my $file1Data = ''; 395 | if ( read(FILE0,$file0Data,$file0Size) == $file0Size && 396 | read(FILE1,$file1Data,$file1Size) == $file1Size ) { 397 | if ( $file0Data eq $file1Data ) { 398 | $result = 1; 399 | } 400 | } 401 | } 402 | close FILE1; 403 | } 404 | close FILE0; 405 | } 406 | } 407 | return $result; 408 | } 409 | 410 | sub Help { 411 | die ' 412 | scdcinepakencode [options] > 413 | 414 | [description] 415 | Outputs an assembly of the desired Cinepak file to the standard output. 416 | 417 | [default usage] 418 | When -custom is not specified, it uses paldata*.bin, palmap*.bin, and 419 | cinepaktiledata*.bin for image frame files (these are default names 420 | used by scdmoviedecode and scdcinepakencodeframe). 421 | 422 | [custom usage] 423 | When -custom is specifies a PERL script, this script should call 424 | &AddImgFrame(...) for each image frame. The PCM data is automatically 425 | interleaved as needed. &AddImgFrame takes four arguments: image duration, 426 | image palette filename, image palette map filename (or empty string for no 427 | map), and cinepak image map filename. The Nyan Cat demo is a simple example 428 | using the custom usage. 429 | 430 | [options] 431 | -width=<#> sets the pixel width of the images 432 | -height=<#> sets the pixel height of the images 433 | -size=<#>x<#> sets the pixel width by height of the images 434 | -id= set the four character id (defaults to SEGA) 435 | -baserate=<#> sets the base rate (ignored, not sure if used, 436 | defaults to 600) 437 | -frameduration=<#> sets the frame duration (only used when not custom) 438 | -pcmfile= pcm file, if not specified, will produce silent movie 439 | -pcmfd=<#> accomodates an encoder with a different FD value 440 | -pcmrate=<#> acoomadates an encoder with a different PCM data rate 441 | -singlepalette= all files use the same single palette 442 | -paldatas= file expr for palette data files 443 | (defaults to paldata*.bin) 444 | -palmaps= file expr for palette map files 445 | (defaults to palmap*.bin) 446 | -cinepaktiledatas= file expr for cinepak tile data files 447 | (defaults to cinepaktiledata*.bin) 448 | -ecco32x encode as Ecco 32X demo deviation of cinepak 449 | -custom= indicates a PERL file to customize the frames 450 | 451 | '; 452 | } 453 | 454 | 455 | -------------------------------------------------------------------------------- /SCDTools/DisFormat.pm: -------------------------------------------------------------------------------- 1 | ############################################################################### 2 | # Copyright (c) 2014 by bgvanbur 3 | # 4 | # This program is free software; you can redistribute it and/or modify it 5 | # under the terms of the GNU General Public License as published by the 6 | # Free Software Foundation; either version 2 of the License, or (at your 7 | # option) any later version. 8 | # 9 | # This program is distributed in the hope that it will be useful, but 10 | # WITHOUT ANY WARRANTY; without even the implied warranty of 11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | # GNU General Public License for more details. 13 | # 14 | # You should have received a copy of the GNU General Public License along 15 | # with this program; if not, write to the Free Software Foundation, Inc., 16 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | ############################################################################### 18 | # Disassemble format Support (for scddisassemble) 19 | ############################################################################### 20 | 21 | package SCDTools::DisFormat; 22 | use strict; 23 | use warnings; 24 | 25 | require Exporter; 26 | our @ISA = qw(Exporter); 27 | our @EXPORT = qw( 28 | SaveCaseUser 29 | RestoreCaseUser 30 | SetCase 31 | SetCaseDir 32 | SetCaseMnem 33 | SetCaseReg 34 | SetCaseImm 35 | 36 | GetCaseDir 37 | GetCaseMnem 38 | GetCaseReg 39 | GetCaseImm 40 | 41 | ApplyCaseDir 42 | ApplyCaseMnem 43 | ApplyCaseReg 44 | ApplyCaseImm 45 | 46 | GetAlwaysOrg 47 | SetAlwaysOrg 48 | ChangeComment 49 | ChangeOrgDirectiveKeyword 50 | ChangeEquDirectiveKeyword 51 | ChangeImmediateFormat 52 | ChangeDataDirectiveKeywords 53 | ChangeDataStringDirectiveKeyword 54 | SetDirectiveStringOnlyIfAllPrintable 55 | ChangeEquUsesColon 56 | ChangeEquUsesLabel 57 | SetAddressWidth 58 | 59 | Disassemble_Org 60 | Disassemble_Equ 61 | 62 | Disassemble_Instruction 63 | Disassemble_Comment 64 | Disassemble_EndOfLineComment 65 | Disassemble_Data_Byte 66 | Disassemble_Data_Word 67 | Disassemble_Data_Long 68 | Disassemble_Data_Byte_Expr 69 | Disassemble_Data_Word_Expr 70 | Disassemble_Data_Long_Expr 71 | Disassemble_Data_String 72 | Disassemble_Data_Align 73 | 74 | Disassemble_Value_3Bits 75 | Disassemble_Value_Nibble 76 | Disassemble_Value_Byte 77 | Disassemble_Value_Byte_Signed 78 | Disassemble_Value_Word 79 | Disassemble_Value_Word_Signed 80 | Disassemble_Value_24Bits 81 | Disassemble_Value_Long 82 | Disassemble_Value_Address 83 | ); 84 | 85 | 86 | ############################################################################### 87 | # Spacing enum 88 | ############################################################################### 89 | 90 | use constant SPACING_NONE => 0x0000; 91 | use constant SPACING_COUNT_MASK => 0x00FF; 92 | use constant SPACING_TAB => 0x0100; 93 | use constant SPACING_SPACE => 0x0200; 94 | use constant SPACING_FIXED => 0x0400; 95 | use constant SPACING_SPACE_FIXED => 0x0600; 96 | 97 | 98 | # upper case by default 99 | my $caseDir = 1; 100 | my $caseMnem = 1; 101 | my $caseReg = 1; 102 | my $caseImm = 1; 103 | my @caseUser = (1,1,1,1); 104 | 105 | my @instructionFormat; 106 | # tab format (annoying) 107 | $instructionFormat[0] = "\t%s\n"; 108 | $instructionFormat[1] = "\t%s\t%s\n"; 109 | $instructionFormat[2] = "\t%s\t%s,%s\n"; 110 | 111 | # 68kd format 112 | $instructionFormat[0] = "\t%s\n"; 113 | $instructionFormat[1] = "\t%-9s%s\n"; 114 | $instructionFormat[2] = "\t%-9s%s,%s\n"; 115 | 116 | # 000000 111 2 3 117 | # MNEM OP1 , OP2 118 | my @spacing = (SPACING_TAB|1,SPACING_SPACE_FIXED|9,SPACING_NONE,SPACING_NONE); 119 | #my @spacing = (SPACING_TAB|1,SPACING_SPACE_FIXED|9,SPACING_NONE,SPACING_SPACE_FIXED|20); 120 | 121 | my $alwaysOrg = 0; 122 | my $equColon = ':'; 123 | my $equLabel = 1; 124 | 125 | # 3bits/nibble/byte/word/long formats 126 | my $immediateFormatPrefix = '$'; 127 | my $immediateFormatSuffix = ''; 128 | my $addressWidth = 32; 129 | my $valueFormat3Bits = "%1.1X"; 130 | my $valueFormatNibble = "\$%1.1X"; 131 | my $valueFormatByte = "\$%2.2X"; 132 | my $valueFormatWord = "\$%4.4X"; 133 | my $valueFormat24Bits = "\$%6.6X"; 134 | my $valueFormatLong = "\$%8.8X"; 135 | my $valueFormatAddress = "\$%8.8X"; 136 | 137 | my $directiveByte = 'dc.b'; 138 | my $directiveWord = 'dc.w'; 139 | my $directiveLong = 'dc.l'; 140 | my $directiveString = 'dc.b'; 141 | my $directiveOrg = 'org'; 142 | my $directiveEqu = 'equ'; 143 | 144 | my $directiveStringOnlyIfAllPrintable = 0; 145 | 146 | my $commentFormat = "\t;; %s\n"; 147 | my $commentFormatEndOfLine = " ;; %s"; # do not include \n 148 | 149 | # old format 150 | # TODO needs to be 6.6 for larger ROMs 151 | # TODO could be smaller for Z80 152 | my $labelGenericFormat = "Label%5.5X"; 153 | 154 | # vasm 68K needs this to be 1 155 | # gas needs this to be 1 156 | my $labelEquNeedLabelToOffsetFrom = 1; 157 | 158 | 159 | 160 | sub SaveCaseUser { 161 | @caseUser = ($caseDir,$caseMnem,$caseReg,$caseImm); 162 | } 163 | sub RestoreCaseUser { 164 | &SetCaseDir( $caseUser[0]); 165 | &SetCaseMnem($caseUser[1]); 166 | &SetCaseReg( $caseUser[2]); 167 | &SetCaseImm( $caseUser[3]); 168 | } 169 | sub SetCase { 170 | my $case = $_[0]; 171 | &SetCaseDir( $case); 172 | &SetCaseMnem($case); 173 | &SetCaseReg( $case); 174 | &SetCaseImm( $case); 175 | } 176 | sub SetCaseDir { 177 | my $case = $_[0]; 178 | $caseDir = $case; 179 | } 180 | sub SetCaseMnem { 181 | my $case = $_[0]; 182 | $caseMnem = $case; 183 | } 184 | sub SetCaseReg { 185 | my $case = $_[0]; 186 | $caseReg = $case; 187 | } 188 | sub SetCaseImm { 189 | my $case = $_[0]; 190 | $caseImm = $case; 191 | &UpdateImmediateFormat(); 192 | } 193 | 194 | sub GetCaseDir { 195 | return $caseDir; 196 | } 197 | sub GetCaseMnem { 198 | return $caseMnem; 199 | } 200 | sub GetCaseReg { 201 | return $caseReg; 202 | } 203 | sub GetCaseImm { 204 | return $caseImm; 205 | } 206 | 207 | sub ApplyCaseDir { 208 | return $caseDir ? uc($_[0]) : lc($_[0]); 209 | } 210 | sub ApplyCaseMnem { 211 | return $caseMnem ? uc($_[0]) : lc($_[0]); 212 | } 213 | sub ApplyCaseReg { 214 | return $caseReg ? uc($_[0]) : lc($_[0]); 215 | } 216 | sub ApplyCaseImm { 217 | return $caseImm ? uc($_[0]) : lc($_[0]); 218 | } 219 | 220 | 221 | 222 | sub GetAlwaysOrg { 223 | return $alwaysOrg; 224 | } 225 | sub SetAlwaysOrg { 226 | $alwaysOrg = $_[0]; 227 | } 228 | 229 | sub ChangeComment { 230 | my $type = $_[0]; 231 | $commentFormat = "\t$type %s\n"; 232 | $commentFormatEndOfLine = " $type %s"; # do not include \n 233 | } 234 | 235 | sub ChangeOrgDirectiveKeyword { 236 | $directiveOrg = $_[0]; 237 | } 238 | 239 | sub ChangeEquDirectiveKeyword { 240 | $directiveEqu = $_[0]; 241 | } 242 | 243 | sub UpdateImmediateFormat { 244 | my $base = $caseImm ? 'X' : 'x'; 245 | $valueFormatNibble = $immediateFormatPrefix."%1.1".$base.$immediateFormatSuffix; 246 | $valueFormatByte = $immediateFormatPrefix."%2.2".$base.$immediateFormatSuffix; 247 | $valueFormatWord = $immediateFormatPrefix."%4.4".$base.$immediateFormatSuffix; 248 | $valueFormat24Bits = $immediateFormatPrefix."%6.6".$base.$immediateFormatSuffix; 249 | $valueFormatLong = $immediateFormatPrefix."%8.8".$base.$immediateFormatSuffix; 250 | &UpdateValueFormatAddress(); 251 | } 252 | 253 | sub ChangeImmediateFormat { 254 | ($immediateFormatPrefix,$immediateFormatSuffix) = @_; 255 | &UpdateImmediateFormat(); 256 | } 257 | 258 | sub ChangeDataDirectiveKeywords { 259 | ($directiveByte,$directiveWord,$directiveLong) = @_; 260 | } 261 | 262 | sub ChangeDataStringDirectiveKeyword { 263 | $directiveString = $_[0]; 264 | } 265 | 266 | sub SetDirectiveStringOnlyIfAllPrintable { 267 | $directiveStringOnlyIfAllPrintable = $_[0]; 268 | } 269 | 270 | sub ChangeEquUsesColon { 271 | if ( $_[0] ) { 272 | $equColon = ':'; 273 | } else { 274 | $equColon = ''; 275 | } 276 | } 277 | 278 | sub ChangeEquUsesLabel { 279 | $equLabel = $_[0]; 280 | } 281 | 282 | sub SetAddressWidth { 283 | $addressWidth = $_[0]; 284 | &UpdateValueFormatAddress(); 285 | } 286 | 287 | sub UpdateValueFormatAddress { 288 | if ( $addressWidth == 8 ) { 289 | $valueFormatAddress = $valueFormatByte; 290 | } elsif ( $addressWidth == 16 ) { 291 | $valueFormatAddress = $valueFormatWord; 292 | } elsif ( $addressWidth == 16 ) { 293 | $valueFormatAddress = $valueFormatWord; 294 | } elsif ( $addressWidth == 24 ) { 295 | $valueFormatAddress = $valueFormat24Bits; 296 | } else { 297 | $valueFormatAddress = $valueFormatLong; 298 | } 299 | } 300 | 301 | sub Disassemble_Equ { 302 | my ($label,$value) = @_; 303 | if ( ! $equLabel ) { 304 | # gas format: .equ symbol, expression 305 | return &Disassemble_Directive($directiveEqu,$label,$value); 306 | } 307 | # label: equ expression 308 | # TODO wish I could use directive format: 309 | return sprintf("%s%s\t%s\t%s\n",$label,$equColon,$directiveEqu,$value); 310 | } 311 | 312 | sub Disassemble_Directive { 313 | # TODO return sprintf($instructionFormat[$#_],@_); 314 | return &Disassemble_Spacing($caseDir,@_); 315 | } 316 | 317 | sub Disassemble_Org { 318 | my $org = $_[0]; 319 | return &Disassemble_Directive($directiveOrg,&Disassemble_Value_Address($org)); 320 | } 321 | 322 | sub Disassemble_Spacing { 323 | my $caseKeyword = $_[0]; 324 | my $keyword = $_[1]; 325 | my $operandCountPlus1 = $#_; 326 | my $result = ''; 327 | # remember to make default spacing the first checked for each 328 | # space so that it is the fastest execution 329 | if ( $spacing[0] & SPACING_TAB ) { 330 | $result .= "\t" x ( $spacing[0] & SPACING_COUNT_MASK ); 331 | } elsif ( $spacing[0] & SPACING_SPACE ) { 332 | # fixed spacing does nothing here, so ignore 333 | $result .= " " x ( $spacing[0] & SPACING_COUNT_MASK ); 334 | } 335 | $result .= $caseKeyword ? uc($keyword) : lc($keyword); 336 | if ( $operandCountPlus1 > 1 ) { 337 | if ( $spacing[1] & SPACING_SPACE ) { 338 | my $count = $spacing[1] & SPACING_COUNT_MASK; 339 | if ( $spacing[1] & SPACING_FIXED ) { 340 | $count -= length($keyword); 341 | } 342 | if ( $count > 0 ) { 343 | $result .= " " x $count; 344 | } 345 | } elsif ( $spacing[1] & SPACING_TAB ) { 346 | $result .= "\t" x ( $spacing[1] & SPACING_COUNT_MASK ); 347 | } 348 | $result .= $_[2]; 349 | for ( my $i = 3; $i <= $operandCountPlus1; $i++ ) { 350 | if ( $spacing[2] ) { 351 | if ( $spacing[2] & SPACING_SPACE ) { 352 | my $count = $spacing[2] & SPACING_COUNT_MASK; 353 | if ( $spacing[2] & SPACING_FIXED ) { 354 | $count -= length($_[$i-1]); 355 | } 356 | if ( $count > 0 ) { 357 | $result .= " " x $count; 358 | } 359 | } elsif ( $spacing[2] & SPACING_TAB ) { 360 | $result .= "\t" x ( $spacing[2] & SPACING_COUNT_MASK ); 361 | } 362 | } 363 | $result .= ','; 364 | if ( $spacing[3] ) { 365 | if ( $spacing[3] & SPACING_SPACE ) { 366 | my $count = $spacing[3] & SPACING_COUNT_MASK; 367 | if ( $spacing[3] & SPACING_FIXED ) { 368 | # include comma 369 | # does not include previous spaces or tabs 370 | # since it doesn't seem like a practical usage 371 | $count -= length($_[$i-1])-1; 372 | } 373 | if ( $count > 0 ) { 374 | $result .= " " x $count; 375 | } 376 | } elsif ( $spacing[3] & SPACING_TAB ) { 377 | $result .= "\t" x ( $spacing[3] & SPACING_COUNT_MASK ); 378 | } 379 | } 380 | $result .= $_[$i]; 381 | } 382 | } 383 | return $result."\n"; 384 | } 385 | 386 | sub Disassemble_Instruction { 387 | # TODO return sprintf($instructionFormat[$#_],@_); 388 | return &Disassemble_Spacing($caseMnem,@_); 389 | } 390 | 391 | sub Disassemble_Comment { 392 | my $result = ''; 393 | foreach my $comment (@_) { 394 | # remove any newlines and beginning whitespace 395 | my $comment2 = $comment; 396 | chomp $comment2; 397 | $comment2 =~ s/^\s+//; 398 | return sprintf($commentFormat,$comment2); 399 | } 400 | return $result; 401 | } 402 | 403 | sub Disassemble_EndOfLineComment { 404 | my ($str,$comment) = @_; 405 | my $commentFull = sprintf($commentFormatEndOfLine,$comment); 406 | $str =~ s/\s*(\n\s*)$/$commentFull$1/; 407 | return $str; 408 | } 409 | 410 | sub Disassemble_Data_Byte { 411 | my ($addr,$width) = @_; 412 | my $inst = ''; 413 | for ( my $i = 0; $i < $width; $i += 16 ) { 414 | my $data = ''; 415 | for ( my $j = 0; $j < 16 && $i + $j < $width; $j++ ) { 416 | if ( $j > 0 ) { 417 | $data .= ","; 418 | } 419 | $data .= &Disassemble_Value_Byte(&SCDTools::DisCommon::GetByte($addr+$i+$j)); 420 | } 421 | $inst .= &Disassemble_Directive($directiveByte,$data); 422 | } 423 | return $inst; 424 | } 425 | 426 | sub Disassemble_Data_Word { 427 | my ($addr,$width) = @_; 428 | my $inst = ''; 429 | for ( my $i = 0; $i < $width; $i += 16 ) { 430 | my $data = ''; 431 | for ( my $j = 0; $j < 16 && $i + $j < $width; $j += 2 ) { 432 | if ( $j > 0 ) { 433 | $data .= ","; 434 | } 435 | $data .= &Disassemble_Value_Word(&SCDTools::DisCommon::GetWord($addr+$i+$j)); 436 | } 437 | $inst .= &Disassemble_Directive($directiveWord,$data); 438 | } 439 | return $inst; 440 | } 441 | 442 | sub Disassemble_Data_Long { 443 | my ($addr,$width) = @_; 444 | my $inst = ''; 445 | for ( my $i = 0; $i < $width; $i += 16 ) { 446 | my $data = ''; 447 | for ( my $j = 0; $j < 16 && $i + $j < $width; $j += 4 ) { 448 | if ( $j > 0 ) { 449 | $data .= ","; 450 | } 451 | $data .= &Disassemble_Value_Long(&SCDTools::DisCommon::GetLong($addr+$i+$j)); 452 | } 453 | $inst .= &Disassemble_Directive($directiveLong,$data); 454 | } 455 | return $inst; 456 | } 457 | 458 | sub Disassemble_Data_Byte_Expr { 459 | return &Disassemble_Data_List_Expr($directiveByte,@_); 460 | } 461 | sub Disassemble_Data_Word_Expr { 462 | return &Disassemble_Data_List_Expr($directiveWord,@_); 463 | } 464 | sub Disassemble_Data_Long_Expr { 465 | return &Disassemble_Data_List_Expr($directiveLong,@_); 466 | } 467 | 468 | sub Disassemble_Data_List_Expr { 469 | my $directive = shift @_; 470 | my $inst = ''; 471 | foreach my $expr (@_) { 472 | $inst .= &Disassemble_Directive($directive,$expr); 473 | } 474 | return $inst; 475 | } 476 | 477 | # TODO should we allow strings? gasmri/asl conflict on 'text' versus "text" 478 | my $commentStringInstead = 1; 479 | 480 | sub Disassemble_Data_String { 481 | my ($addr,$width) = @_; 482 | my $data = ''; 483 | my $inString = 0; 484 | my $strDelim = '"'; 485 | if ( $commentStringInstead || $directiveStringOnlyIfAllPrintable ) { 486 | for ( my $i = 0; $i < $width; $i += 1 ) { 487 | my $byte = &SCDTools::DisCommon::GetByte($addr+$i); 488 | if ( ! ( $byte >= 0x20 && $byte < 0x7F ) ) { 489 | return &Disassemble_Data_Byte(@_); 490 | } 491 | } 492 | } 493 | for ( my $i = 0; $i < $width; $i += 1 ) { 494 | my $byte = &SCDTools::DisCommon::GetByte($addr+$i); 495 | if ( $byte >= 0x20 && $byte < 0x7F ) { 496 | # printable characters 497 | if ( ! $inString ) { 498 | if ( $i > 0 ) { 499 | $data .= ','; 500 | } 501 | # open string 502 | $data .= $strDelim; 503 | } 504 | if ( chr($byte) eq $strDelim ) { 505 | # need to escape string delimiter 506 | $data .= '\\'.$strDelim; 507 | } else { 508 | $data .= sprintf("%c",$byte); 509 | } 510 | $inString = 1; 511 | } else { 512 | # non-printable characters 513 | if ( $inString ) { 514 | # close string 515 | $data .= $strDelim; 516 | } 517 | if ( $i > 0 ) { 518 | $data .= ','; 519 | } 520 | $data .= &Disassemble_Value_Byte($byte); 521 | $inString = 0; 522 | } 523 | } 524 | if ( $inString ) { 525 | # close string 526 | $data .= $strDelim; 527 | } 528 | if ( $commentStringInstead ) { 529 | return &Disassemble_Comment($data).&Disassemble_Data_Byte(@_); 530 | } 531 | return &Disassemble_Directive($directiveString,$data); 532 | } 533 | 534 | sub Disassemble_Value_3Bits { 535 | # caller needs to verify bits within lowest nibble 536 | # since also used to print 1-8 values 537 | return sprintf($valueFormat3Bits,$_[0] & 0xF); 538 | } 539 | sub Disassemble_Value_Nibble { 540 | return sprintf($valueFormatNibble,$_[0] & 0xF); 541 | } 542 | sub Disassemble_Value_Byte { 543 | return sprintf($valueFormatByte,$_[0] & 0xFF); 544 | } 545 | sub Disassemble_Value_Byte_Signed { 546 | my $data = $_[0] & 0xFF; 547 | if ( $data & 0x80 ) { 548 | my $dataNeg = ( $data ^ 0xFF ) + 1; 549 | return '-'.sprintf($valueFormatByte,$dataNeg); 550 | } 551 | return sprintf($valueFormatByte,$data); 552 | } 553 | sub Disassemble_Value_Word { 554 | return sprintf($valueFormatWord,$_[0] & 0xFFFF); 555 | } 556 | sub Disassemble_Value_Word_Signed { 557 | my $data = $_[0] & 0xFFFF; 558 | if ( $data & 0x8000 ) { 559 | my $dataNeg = ( $data ^ 0xFFFF ) + 1; 560 | return '-'.sprintf($valueFormatWord,$dataNeg); 561 | } 562 | return sprintf($valueFormatWord,$data); 563 | } 564 | sub Disassemble_Value_24Bits { 565 | return sprintf($valueFormat24Bits,$_[0] & 0xFFFFFF); 566 | } 567 | sub Disassemble_Value_Long { 568 | return sprintf($valueFormatLong,$_[0] & 0xFFFFFFFF); 569 | } 570 | sub Disassemble_Value_Address { 571 | return sprintf($valueFormatAddress,$_[0]); 572 | } 573 | 574 | 575 | 576 | 1; 577 | -------------------------------------------------------------------------------- /SCDTools/Palette.pm: -------------------------------------------------------------------------------- 1 | ############################################################################### 2 | # Copyright (c) 2012 by bgvanbur 3 | # 4 | # This program is free software; you can redistribute it and/or modify it 5 | # under the terms of the GNU General Public License as published by the 6 | # Free Software Foundation; either version 2 of the License, or (at your 7 | # option) any later version. 8 | # 9 | # This program is distributed in the hope that it will be useful, but 10 | # WITHOUT ANY WARRANTY; without even the implied warranty of 11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | # GNU General Public License for more details. 13 | # 14 | # You should have received a copy of the GNU General Public License along 15 | # with this program; if not, write to the Free Software Foundation, Inc., 16 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 17 | ############################################################################### 18 | # handle palettes for megadrive/megacd development 19 | ############################################################################### 20 | 21 | package SCDTools::Palette; 22 | use strict; 23 | use warnings; 24 | 25 | my $tmpFile = 'TMP.BIN'; 26 | my $tmpFileRemoveAfterUse = 1; 27 | my $constantColorBlack = chr(0x00).chr(0x00); 28 | my $constantColorPink = chr(0x0E).chr(0x0E); 29 | 30 | # [ 0 3 ] 31 | # [ 2 1 ] 32 | my @orderDitherMatrix2x2 = ( 0, 3, 2, 1 ); 33 | 34 | # [ 0 6 1 7 ] 35 | # [ 4 2 5 3 ] 36 | my @orderDitherMatrix4x2 = ( 0, 6, 1, 7, 4, 2, 5, 3 ); 37 | 38 | # [ 0 6 ] 39 | # [ 4 2 ] 40 | # [ 1 7 ] 41 | # [ 5 3 ] 42 | my @orderDitherMatrix2x4 = ( 0, 6, 4, 2, 1, 7, 5, 3 ); 43 | 44 | # [ 0 12 3 15 ] 45 | # [ 8 4 11 7 ] 46 | # [ 2 14 1 13 ] 47 | # [ 10 6 9 5 ] 48 | my @orderDitherMatrix4x4 = ( 0, 12, 3, 15, 8, 4, 11, 7, 2, 14, 1, 13, 10, 6, 9, 5 ); 49 | 50 | # [ 0 48 12 60 3 51 15 63 ] 51 | # [ 32 16 44 28 35 19 47 31 ] 52 | # [ 8 56 4 52 11 59 7 55 ] 53 | # [ 40 24 36 20 43 27 39 23 ] 54 | # [ 2 50 14 62 1 49 13 61 ] 55 | # [ 34 18 46 30 33 17 45 29 ] 56 | # [ 10 58 6 54 9 57 5 53 ] 57 | # [ 42 26 38 22 41 25 37 21 ] 58 | my @orderDitherMatrix8x8 = ( 0, 48, 12, 60, 3, 51, 15, 63, 32, 16, 44, 28, 35, 19, 47, 31, 8, 56, 4, 52, 11, 59, 7, 55, 40, 24, 36, 20, 43, 27, 39, 23, 2, 50, 14, 62, 1, 49, 13, 61, 34, 18, 46, 30, 33, 17, 45, 29, 10, 58, 6, 54, 9, 57, 5, 53, 42, 26, 38, 22, 41, 25, 37, 21 ); 59 | 60 | # TODO need a consistent method for color indexing 61 | 62 | sub GetHelpString { 63 | return '[options-palette] 64 | -asmpal= output palette to assembly file 65 | -binpal= output palette to binary file 66 | -palfile= specifies the palette 67 | -paloffset=<#> palette offset of the first palette in the palette file 68 | -palbyteoffset=<#> byte offset of the first palette in the palette file 69 | -palcount=<#> specifies the number of palettes in use 70 | -magicpink treat #FF00FF as transparent 71 | -magicblack treat #000000 as transparent 72 | -colorzeronormal treat color zero of each palette as a normal pixel 73 | -directcolor treat palette as 512 colors 74 | -addcolor=BGR add VDP hex color to palette 75 | '; 76 | } 77 | 78 | sub new { 79 | my($class) = @_; 80 | 81 | my $self = bless({}, $class); 82 | 83 | $self->{'colors'} = []; 84 | $self->{'colorsCount'} = 0; 85 | $self->{'colorsCountRead'} = 0; 86 | $self->{'colorsMissing'} = {}; 87 | $self->{'entriesPerPalette'} = 16; 88 | $self->{'colorsPerPalette'} = 15; 89 | $self->{'paletteCount'} = 1; 90 | $self->{'fileOutputAsm'} = ''; 91 | $self->{'fileOutputBin'} = ''; 92 | $self->{'fileInput'} = ''; 93 | $self->{'fileInputOffset'} = 0; 94 | $self->{'magicPink'} = 0; 95 | $self->{'magicBlack'} = 0; 96 | $self->{'verbosity'} = 2; 97 | $self->{'comments'} = 1; 98 | $self->{'labels'} = 1; 99 | $self->{'label'} = ''; 100 | 101 | return $self; 102 | } 103 | 104 | sub Reset { 105 | my ($self) = @_; 106 | $self->SetMaxColorCount($self->{'colorsCountRead'}); 107 | } 108 | 109 | sub SetMaxColorCount { 110 | my ($self,$count) = @_; 111 | if ( $self->{'colorsCount'} > $count ) { 112 | splice(@{$self->{'colors'}},$count); 113 | $self->{'colorsCount'} = $count; 114 | if ( $count < $self->{'colorsCountRead'} ) { 115 | $self->{'colorsCountRead'} = $count; 116 | } 117 | } 118 | } 119 | 120 | # TODO inconsistent indexing... 121 | sub GetColor { 122 | my ($self,$index) = @_; 123 | if ( $index <= $#{$self->{'colors'}} ) { 124 | return $self->{'colors'}[$index]; 125 | } 126 | return chr(0x00).chr(0x00); 127 | } 128 | 129 | 130 | sub GetColorsCountRead { 131 | my ($self) = @_; 132 | return $self->{'colorsCountRead'}; 133 | } 134 | 135 | sub GetColorsCount { 136 | my ($self) = @_; 137 | return $self->{'colorsCount'}; 138 | } 139 | 140 | sub GetEntriesPerPalette { 141 | my ($self) = @_; 142 | return $self->{'entriesPerPalette'}; 143 | } 144 | 145 | sub GetColorsPerPalette { 146 | my ($self) = @_; 147 | return $self->{'colorsPerPalette'}; 148 | } 149 | 150 | sub GetPaletteCount { 151 | my ($self) = @_; 152 | return $self->{'paletteCount'}; 153 | } 154 | 155 | sub SetPaletteCount { 156 | my ($self,$arg) = @_; 157 | $self->{'paletteCount'} = $arg; 158 | } 159 | 160 | sub ParseArg { 161 | my ($self,$arg) = @_; 162 | if ( $arg =~ /^-pal(ette)?count=(\d+)$/i ) { 163 | $self->{'paletteCount'} = $2; 164 | } elsif ( $arg =~ /^-asmpal(ette)?=(.*)$/i ) { 165 | $self->{'fileOutputAsm'} = $2; 166 | } elsif ( $arg =~ /^-binpal(ette)?=(.*)$/i ) { 167 | $self->{'fileOutputBin'} = $2; 168 | } elsif ( $arg =~ /^-pal(ette)?file=(.+)$/i ) { 169 | $self->{'fileInput'} = $2; 170 | } elsif ( $arg =~ /^-pal(ette)?byteoffset=0x([0-9A-F]+)/i ) { 171 | $self->{'fileInputOffset'} = hex($2); 172 | } elsif ( $arg =~ /^-pal(ette)?byteoffset=(\d+)/i ) { 173 | $self->{'fileInputOffset'} = $2; 174 | } elsif ( $arg =~ /^-pal(ette)?offset=(0x[0-9A-F]+)$/i ) { 175 | $self->{'fileInputOffset'} = 32 * hex($2); 176 | } elsif ( $arg =~ /^-pal(ette)?offset=(\d+)$/i ) { 177 | $self->{'fileInputOffset'} = 32 * $2; 178 | } elsif ( $arg =~ /^-pal(ette)?count=(\d+)$/i ) { 179 | $self->{'paletteCount'} = $2; 180 | } elsif ( $arg =~ /^-magicpink$/i ) { 181 | $self->{'magicPink'} = 1; 182 | } elsif ( $arg =~ /^-magicblack$/i ) { 183 | $self->{'magicBlack'} = 1; 184 | } elsif ( $arg =~ /^-colorzeronormal$/i ) { 185 | $self->{'colorsPerPalette'} = 16; 186 | $self->{'entriesPerPalette'} = 16; 187 | } elsif ( $arg =~ /^-directcolor$/i ) { 188 | $self->{'colorsPerPalette'} = 512; 189 | $self->{'entriesPerPalette'} = 512; 190 | } elsif ( $arg =~ /^-addcolor=([02468ACE]{3})$/i ) { 191 | my $colorString = $1; 192 | my $color = chr(hex(substr($colorString,0,1))).chr((hex(substr($colorString,1,1))<<4)|(hex(substr($colorString,2,1)))); 193 | $self->AddColor($color); 194 | $self->{'colorsCountRead'} = $self->{'colorsCount'}; 195 | } else { 196 | if ( $arg =~ /^-nocomments$/i ) { 197 | $self->{'comments'} = 0; 198 | } elsif ( $arg =~ /^-nolabels$/i ) { 199 | $self->{'labels'} = 0; 200 | } elsif ( $arg =~ /^-label=(.+)$/i ) { 201 | $self->{'label'} = $1; 202 | } elsif ( $arg =~ /^-v=(\d+)$/i ) { 203 | $self->{'verbosity'} = $1; 204 | } 205 | return 0; 206 | } 207 | return 1; 208 | } 209 | 210 | sub ReadPalette { 211 | my ($self) = @_; 212 | my $fileInput = $self->{'fileInput'}; 213 | if ( $fileInput eq '' ) { 214 | return; 215 | } 216 | if ( ! -e $fileInput ) { 217 | die "Bad palette file: ".$fileInput."\n"; 218 | } 219 | my $tmpFileRemove = 0; 220 | if ( $fileInput =~ m/\.(asm|68k)$/i ) { 221 | my $asmFile = $fileInput; 222 | $fileInput = $tmpFile; 223 | $tmpFileRemove = $tmpFileRemoveAfterUse; 224 | system("scdasm -v=".$self->{'verbosity'}." $asmFile ".$fileInput); 225 | if ( ! -e $fileInput ) { 226 | die "Bad scdasm since didn't make: $fileInput"; 227 | } 228 | } 229 | 230 | if ( $self->{'paletteCount'} <= 0 ) { 231 | # allow partial palette to count as a whole palette 232 | $self->{'paletteCount'} = int( ( ( -s $fileInput ) - $self->{'fileInputOffset'} + 2*$self->{'entriesPerPalette'}-1 ) / ( 2 * $self->{'entriesPerPalette'} ) ); 233 | } 234 | 235 | my $paletteCountInBytes = 32 * $self->{'paletteCount'}; 236 | my $paletteData = chr(0x00)x$paletteCountInBytes; 237 | 238 | open( DATA, $fileInput ) or die "Cannot read palette file: $!\n"; 239 | binmode DATA; 240 | seek(DATA,$self->{'fileInputOffset'},0); 241 | my $paletteReadCountInBytes = read(DATA,$paletteData,$paletteCountInBytes); 242 | # for a partial palette, do not add empty colors 243 | # will add these on output 244 | for ( my $paletteDataByte = 0; $paletteDataByte < $paletteReadCountInBytes; $paletteDataByte += 2 ) { 245 | # may add color zero of each palette depending on -colorzeronormal 246 | if ( ( ( $paletteDataByte >> 1 ) & 0xF ) >= $self->{'entriesPerPalette'} - $self->{'colorsPerPalette'} ) { 247 | $self->AddColor(substr($paletteData,$paletteDataByte,2)); 248 | } 249 | } 250 | close DATA; 251 | 252 | if ( $tmpFileRemove ) { 253 | unlink $tmpFile; 254 | } 255 | 256 | $self->{'colorsCountRead'} = $self->{'colorsCount'}; 257 | } 258 | 259 | sub OutputPalette { 260 | my ($self) = @_; 261 | $self->OutputPaletteForFileAndBinMode($self->{'fileOutputAsm'},0); 262 | $self->OutputPaletteForFileAndBinMode($self->{'fileOutputBin'},1); 263 | } 264 | 265 | sub OutputPaletteForFileAndBinMode { 266 | my ($self,$file,$bin) = @_; 267 | if ( $file eq '' ) { 268 | return; 269 | } 270 | my $fileContents = $self->GetOutputPaletteData($bin); 271 | open(DATA,'>'.$file); 272 | if ( $bin ) { 273 | binmode DATA; 274 | } 275 | print DATA $fileContents; 276 | close DATA; 277 | } 278 | 279 | sub GetOutputPaletteData { 280 | my ($self,$bin) = @_; 281 | if ( $self->{'colorsCount'} <= 0 ) { 282 | return ''; 283 | } 284 | my $fileContents = ''; 285 | if ( ! $bin ) { 286 | if ( $self->{'comments'} ) { 287 | $fileContents .= ";; palette\n"; 288 | } 289 | if ( $self->{'labels'} ) { 290 | $fileContents .= "Start".$self->{'label'}."Palette:\n"; 291 | } 292 | } 293 | for ( my $paletteIndex = 0; $paletteIndex < $self->{'paletteCount'}; $paletteIndex++ ) { 294 | for ( my $i = 0; $i < ($self->{'entriesPerPalette'}-$self->{'colorsPerPalette'}); $i++ ) { 295 | if ( $bin ) { 296 | $fileContents .= pack("n",0x0000); 297 | } else { 298 | $fileContents .= " dc.w \$0000\n"; 299 | } 300 | } 301 | for ( my $i = 0; $i < $self->{'colorsPerPalette'}; $i++ ) { 302 | my $colorsIndex = $paletteIndex * $self->{'colorsPerPalette'} + $i; 303 | if ( $colorsIndex < $self->{'colorsCount'} ) { 304 | if ( $bin ) { 305 | $fileContents .= $self->{'colors'}[$colorsIndex]; 306 | } else { 307 | my $colorf = sprintf("\$%4.4X",unpack("n",$self->{'colors'}[$colorsIndex])); 308 | $fileContents .= ' dc.w '.$colorf."\n"; 309 | } 310 | } else { 311 | if ( $bin ) { 312 | $fileContents .= pack("n",0x0000); 313 | } else { 314 | $fileContents .= " dc.w \$0000\n"; 315 | } 316 | } 317 | } 318 | } 319 | if ( ! $bin && $self->{'labels'} ) { 320 | $fileContents .= "End".$self->{'label'}."Palette:\n"; 321 | } 322 | return $fileContents; 323 | } 324 | 325 | my %cache; 326 | 327 | sub GetColorIndex { 328 | my ($self,$color) = @_; 329 | my $index = -1; 330 | if ( ( $self->{'magicPink'} && $color eq $constantColorPink ) || 331 | ( $self->{'magicBlack'} && $color eq $constantColorBlack ) ) { 332 | $index = 0; 333 | } else { 334 | $index = $self->GetColorIndexWithNoAdding($color); 335 | if ( $index < 0 ) { 336 | $index = $self->AddColor($color); 337 | } 338 | } 339 | return $index; 340 | } 341 | 342 | sub GetColorIndexWithNoAdding { 343 | my ($self,$color) = @_; 344 | my $index = -1; 345 | my $colorsCount = $self->{'colorsCount'}; 346 | for ( my $colorsIndex = 0; $colorsIndex < $colorsCount; $colorsIndex++ ) { 347 | if ( $color eq $self->{'colors'}[$colorsIndex] ) { 348 | # account for each palette having unused transparent index 349 | $index = ( $colorsIndex % $self->{'colorsPerPalette'} ) + $self->{'entriesPerPalette'} * int($colorsIndex / $self->{'colorsPerPalette'}) + ($self->{'entriesPerPalette'}-$self->{'colorsPerPalette'}); 350 | last; 351 | } 352 | } 353 | return $index; 354 | } 355 | 356 | # TODO bounds checking 357 | sub SetColor { 358 | my ($self,$index,$color) = @_; 359 | $self->{'colors'}[$index] = $color; 360 | } 361 | 362 | sub AddColor { 363 | my ($self,$color) = @_; 364 | my $index = -1; 365 | if ( $self->{'colorsCount'} < $self->{'colorsPerPalette'} * $self->{'paletteCount'} ) { 366 | push @{$self->{'colors'}}, $color; 367 | my $colorsIndex = $self->{'colorsCount'}; 368 | $index = ( $colorsIndex % $self->{'colorsPerPalette'} ) + $self->{'entriesPerPalette'} * int($colorsIndex / $self->{'colorsPerPalette'}) + ($self->{'entriesPerPalette'}-$self->{'colorsPerPalette'}); 369 | $self->{'colorsCount'}++; 370 | # debug print 371 | # printf("Adding color $index : \$%4.4X\n",unpack("n",$color)); 372 | } else { 373 | $self->{'colorsMissing'}{$color}++; 374 | $index = -1; 375 | } 376 | return $index; 377 | } 378 | 379 | sub AddColorsFromImageMagickImage { 380 | my ($self,$img) = @_; 381 | use Image::Magick; 382 | 383 | my $width = $img->Get('width'); 384 | my $height = $img->Get('height'); 385 | my $alpha = $img->Get('matte'); 386 | 387 | # used to keep track of frequency of colors 388 | my @colors; 389 | 390 | for ( my $i = 0; $i < 8*8*8; $i++ ) { 391 | $colors[$i] = 0; 392 | } 393 | 394 | for ( my $y = 0; $y < $height; $y++ ) { 395 | for ( my $x = 0; $x < $width; $x++ ) { 396 | my $a = 0; 397 | if ( $alpha ) { 398 | $a = $img->GetPixel('channel'=>'Alpha','normalize'=>1,'x'=>$x,'y'=>$y); 399 | # TODO 95% or 100% or something else? 400 | if ( defined $a && $a > 0.95 ) { 401 | next; 402 | } 403 | } 404 | my ($r,$g,$b) = $img->GetPixel('channel'=>'RGB','normalize'=>1,'x'=>$x,'y'=>$y); 405 | # 15% performance optimization: use simpler format to store color 406 | my $colorInt = &SCDTools::Palette::ConvertRGBNormalizedToVDPColorInt($r,$g,$b); 407 | $colors[$colorInt]++; 408 | } 409 | } 410 | 411 | # add colors in order of most used to least used 412 | foreach my $colorInt ( sort { $colors[$b] <=> $colors[$a] || $a <=> $b } (0..8*8*8-1) ) { 413 | if ( $colors[$colorInt] == 0 ) { 414 | last; 415 | } 416 | my $color = &SCDTools::Palette::ConvertVDPColorIntToVDPColor($colorInt); 417 | $self->GetColorIndex($color); 418 | } 419 | } 420 | 421 | sub UpdateImageMagickPalette { 422 | my ($self,$imgPalette) = @_; 423 | use Image::Magick; 424 | 425 | my $colorsCount = $self->{'colorsCount'}; 426 | 427 | $imgPalette->Set(size=>"${colorsCount}x1"); 428 | my $x = $imgPalette->ReadImage('xc:black'); 429 | warn $x if $x; 430 | 431 | for ( my $colorsIndex = 0; $colorsIndex < $colorsCount; $colorsIndex++ ) { 432 | my $color = $self->{'colors'}[$colorsIndex]; 433 | my @pixels = &ConvertVDPColorToRGBNormalized($color); 434 | $imgPalette->SetPixel('channel'=>'RGB','x'=>$colorsIndex,'y'=>0,'color'=>\@pixels); 435 | } 436 | } 437 | 438 | sub Convert { 439 | my ($self,$type) = @_; 440 | my $colorsCount = $self->{'colorsCount'}; 441 | for ( my $colorsIndex = 0; $colorsIndex < $colorsCount; $colorsIndex++ ) { 442 | my $cOld = $self->{'colors'}[$colorsIndex]; 443 | my $cNew; 444 | if ( $type eq 'greyavg' ) { 445 | my ($r,$g,$b) = &ConvertVDPColorToRGBNormalized($cOld); 446 | my $avg = ($r+$g+$b)/3.0; 447 | $cNew = &ConvertRGBNormalizedToVDPColor($avg,$avg,$avg); 448 | } elsif ( $type eq 'desaturate50' ) { 449 | my ($r,$g,$b) = &ConvertVDPColorToRGBNormalized($cOld); 450 | my $avg = ($r+$g+$b)/3.0; 451 | $cNew = &ConvertRGBNormalizedToVDPColor(0.5*($r+$avg),0.5*($g+$avg),0.5*($b+$avg)); 452 | } elsif ( $type eq 'invert' ) { 453 | my ($r,$g,$b) = &ConvertVDPColorToRGBNormalized($cOld); 454 | my $avg = ($r+$g+$b)/3.0; 455 | $cNew = &ConvertRGBNormalizedToVDPColor(1.0-$r,1.0-$g,1.0-$b); 456 | } elsif ( $type eq 'redonly' ) { 457 | my ($r,$g,$b) = &ConvertVDPColorToRGBNormalized($cOld); 458 | my $avg = ($r+$g+$b)/3.0; 459 | $cNew = &ConvertRGBNormalizedToVDPColor($r,0,0); 460 | } elsif ( $type eq 'greenonly' ) { 461 | my ($r,$g,$b) = &ConvertVDPColorToRGBNormalized($cOld); 462 | my $avg = ($r+$g+$b)/3.0; 463 | $cNew = &ConvertRGBNormalizedToVDPColor(0,$g,0); 464 | } elsif ( $type eq 'blueonly' ) { 465 | my ($r,$g,$b) = &ConvertVDPColorToRGBNormalized($cOld); 466 | my $avg = ($r+$g+$b)/3.0; 467 | $cNew = &ConvertRGBNormalizedToVDPColor(0,0,$b); 468 | } else { 469 | $cNew = $cOld; 470 | } 471 | $self->{'colors'}[$colorsIndex] = $cNew; 472 | } 473 | } 474 | 475 | sub ConvertRGBNormalizedToVDPColorInt { 476 | my ($r,$g,$b) = @_; 477 | return (int((255*$b)>>5)<<6)|(int((255*$g)>>5)<<3)|(int((255*$r)>>5)); 478 | } 479 | 480 | sub ConvertVDPColorIntToVDPColor { 481 | my ($colorInt) = @_; 482 | return chr(0x0E & ($colorInt>>5)).chr((0xE0 & ($colorInt<<2))|(0x0E & ($colorInt<<1))); 483 | } 484 | 485 | sub ConvertRGBNormalizedToVDPColor { 486 | my ($r,$g,$b) = @_; 487 | return chr(int((255*$b)>>5)<<1).chr((int((255*$g)>>5)<<5)|(int((255*$r)>>5)<<1)); 488 | } 489 | 490 | sub ConvertVDPColorToRGBNormalized { 491 | my ($c) = @_; 492 | # TODO inverse it 493 | # pixel: 0-7 494 | # (pixel*32/255) is lowest part 495 | # add 1/16 to get to highlight 496 | # add 1/32 to get halway between regular and highlight 497 | return ((ord(substr($c,1,1))&0xE)/15.0,((ord(substr($c,1,1))>>4)&0xE)/15.0,(ord(substr($c,0,1))&0xE)/15.0); 498 | } 499 | 500 | sub ConvertVDPColorToRGB24Bit { 501 | my ($c) = @_; 502 | return chr(((ord(substr($c,1,1))&0xE)/15.0)*255).chr((((ord(substr($c,1,1))>>4)&0xE)/15.0)*255).chr(((ord(substr($c,0,1))&0xE)/15.0)*255); 503 | } 504 | 505 | sub PrintMissingColors { 506 | my ($self) = @_; 507 | my @colors = sort {$self->{'colorsMissing'}{$b} <=> $self->{'colorsMissing'}{$a}} keys %{$self->{'colorsMissing'}}; 508 | foreach my $color (@colors) { 509 | my $count = $self->{'colorsMissing'}{$color}; 510 | my $colorf = sprintf("\$%4.4X",unpack("n",$color)); 511 | print STDERR "Palette does not contain color: $colorf ($count)\n"; 512 | } 513 | } 514 | 515 | sub GetOrderedDitherAdd { 516 | # returns value between 0 and 255 or -1 if invalid format 517 | my ($format,$x,$y) = @_; 518 | my $orderedDitherAdd = 0; 519 | if ( $format eq '8x8' ) { 520 | $orderedDitherAdd = $orderDitherMatrix8x8[(8*($y & 7)+($x & 7))] << 2; 521 | } elsif ( $format eq '4x4' ) { 522 | $orderedDitherAdd = $orderDitherMatrix4x4[(4*($y & 3)+($x & 3))] << 4; 523 | } elsif ( $format eq '4x2' ) { 524 | $orderedDitherAdd = $orderDitherMatrix4x2[(4*($y & 1)+($x & 3))] << 5; 525 | } elsif ( $format eq '2x4' ) { 526 | $orderedDitherAdd = $orderDitherMatrix2x4[(2*($y & 3)+($x & 1))] << 5; 527 | } elsif ( $format eq '2x2' ) { 528 | $orderedDitherAdd = $orderDitherMatrix2x2[(2*($y & 1)+($x & 1))] << 6; 529 | } else { 530 | return -1; 531 | } 532 | return $orderedDitherAdd; 533 | } 534 | 535 | 1; 536 | 537 | --------------------------------------------------------------------------------