#!/usr/bin/perl my %patchtable=(); my $offset = 13615; my $programsize = 7509409; sub parsenat($) { my $dna = $_[0]; my $nat = 0; my $i; for ($i = length($dna)-2; $i >= 0; $i--) { $nat += $nat; $nat ++ if (substr($dna,$i,1) eq "C"); } return $nat; } sub natfix($$) { my $len = $_[1]; my $n = $_[0]; my $i; my $res =""; for ($i = 0; $i < $len-1; $i++) { $res .= ($n & 1 ? "C" : "I"); $n >>=1; } return $res."P"; } sub nat($) { my $res = ""; my $n = $_[0]; if ($n =~ /\[(.*)\]/) { my $idx = $1; my $pat = substr("*$1************************************", 0, 23); my $res .= $pat; $patchtable{$idx} = $pat; return $pat."P"; } if ($n =~ /0x(.*)/) { $n = hex($1); } while ($n > 0) { $res .= ($n & 1 ? "C" : "I"); $n >>=1; } return $res."P"; } sub quote($) { my $p = $_[0]; $p =~ tr/ICFP/CFPI/; $p =~ s/I/IC/g; $p =~ s/q(q*f?m[0-9]+,[0-9]+)/$1/g; return $p; } sub antiquote($) { my $p = $_[0]; $p =~ s/./q$&/g; return $p; } sub pattern($){ my $p = $_[0]; my $res=""; # print STDERR "pattern:$p:"; while ($p) { my $oldp = $p; if ($p =~ s/^((0x)?[0-9a-f]+|\[[^\]]*\])(:([0-9]+))?//) { if ($3) { $res .= natfix($1,$4); } else { $res .= nat($1); } } $p =~ s/^p<(([^<>]|<([^<>]|<[^<>]*>)*>)*)>/pattern($1)/e; $p =~ s/^p!<(([^<>]|<([^<>]|<[^<>]*>)*>)*)>/$_=pattern($1);$_=~s!IIC$!!;$_/e; $p =~ s/^t<(([^<>]|<([^<>]|<[^<>]*>)*>)*)>/template($1)/e; $res .= "$1" if ($p =~ s/^q(q*f?m[0-9]+,[0-9]+|l[0-9]+|[ICFP])//); $res .= "IFC" if ($p =~ s/^\?//); $res .= "IP" if ($p =~ s/^\!//); $res .= "IIP" if ($p =~ s/^\(//); $res .= "IIC" if ($p =~ s/^\)//); $res .= "III$1" if ($p =~ s/^r([IFCP]{7})//); $res .= quote($1) if ($p =~ s/^([IFCP]+)//); die "illegal pattern $p" if ($p eq $oldp); } # print STDERR "${res}IIC\n"; return $res . "IIC"; } sub template($){ my $p = $_[0]; my $res=""; # print STDERR "template:$p:"; while ($p) { my $oldp = $p; if ($p =~ s/^m([0-9]+),([0-9]+)//) { $res .= "IP".nat($1).nat($2); } if ($p =~ s/^fm([0-9]+),([0-9]+)//) { $res .= "IF".nat($1).nat($2); } if ($p =~ s/^l([0-9]+)//) { $res .= "IIP".nat($1); } $p =~ s/^p<(([^<>]|<([^<>]|<([^<>]|<([^<>]|<[^<>]*>)*>)*>)*>)*)>/ pattern($1)/e; $p =~ s/^p!<(([^<>]|<([^<>]|<([^<>]|<([^<>]|<[^<>]*>)*>)*>)*>)*)>/ $_=pattern($1);$_=~s!IIC$!!;$_/e; $p =~ s/^t<(([^<>]|<([^<>]|<([^<>]|<([^<>]|<[^<>]*>)*>)*>)*>)*)>/ template($1)/e; $res .= $1 if ($p =~ s/^q(q*f?m[0-9]+,[0-9]+|l[0-9]+|[ICFP])//); $res .= "III$1" if ($p =~ s/r([IFCP]{7})//); $res .= quote($1) if ($p =~ s/^([IFCP]+)//); die "illegal template $p" if ($p eq $oldp); } # print STDERR "${res}IIC\n"; return $res . "IIC"; } my %lengths = ( "outcolor" => 6709, ); my %addresses = ( "outcolor" => 4312088 ); sub callfunc { my $skipbefore = shift @_; my $func = shift @_; my $skip1 = $skipbefore+$offset; my $addr = $addresses{$func}; my $len= $lengths{$func}; if (!@_) { return pattern("!$skip1($addr(!$len))"). template("m0,0m0,1"); } else { my $param =""; foreach (@_) { $param = $param.natfix($_,24); } $skip2 = $programsize - $addresses{$func} - $len; return pattern("!$skip1(!$addr(!$len)!$skip2)"). template("m0,0m0,1$param"); } } sub skipall() { return pattern("?IFPICFPPCIFP."); } #$prefix=skipall(); #$prefix=callfunc(length($prefix), "outcolor", 6402682, 2010).$prefix; #print $pattern."\n"; # Patch code in method "6628979" # RNA nr 280760 #$pattern = pattern("!440").template(""); #$len = length($pattern); #$pattern = pattern("!".(440-$len)).template(""); #die "$len / $pattern" if ($len != length ($pattern)); #$prelen = 0; #$prefix = pattern("(!".(6642614+$prelen).")!".length($pattern)). # template("m0,0".$pattern); #print pattern("(?CIFPP.)F").template("m0,0I"); #sub lenpattern($$) { # my ($ptrn, $tmpl) = @_; # my $len = 10; # my $oldlen = 0; # my $pattern; # do { # $oldlen = $len; # $pptrn = $ptrn; # $pptrn =~ s/(0x([0-9a-f]+)-len)/hex($1)-$oldlen/eg; # $pptrn =~ s/(([0-9a-f]+)-len)/$1-$oldlen/eg; # print STDERR "pattern $oldlen:$pptrn\n"; # $pattern = pattern($pptrn).template($tmpl); # $len = length($pattern); # } while ($len != $oldlen); # return $pattern; #} #my $prefix = ""; #sub addprefix($$) { # my ($ptrn, $tmpl) = @_; # print STDERR "addprefix:$ptrn:$tmpl\n"; # $ptrn =~ s/0x([0-9a-f]+)\+off/hex($1)+$offset+length($prefix)/eg; # $ptrn =~ s/([0-9]+)\+off/$1+$offset+length($prefix)/eg; ## print STDERR "addprefix:$ptrn:$tmpl\n"; # $prefix = pattern($ptrn).template($tmpl). $prefix; ## print STDERR "-->$prefix\n"; #} ###########3 sub lenpattern($$) { my ($ptrn, $tmpl) = @_; my $len = 10; my $oldlen = 0; my $pattern; do { $oldlen = $len; $pptrn = $ptrn; $pptrn =~ s/0x([0-9a-f]+)-len/hex($1)-$oldlen/eg; $pptrn =~ s/([0-9]+)-len/$1-$oldlen/eg; $pptrn =~ s/0x([0-9a-f]+)\+len/hex($1)+$oldlen/eg; $pptrn =~ s/([0-9]+)\+len/$1+$oldlen/eg; # print STDERR "pattern $oldlen:$pptrn\n"; $pattern = pattern($pptrn).template($tmpl); $len = length($pattern); } while ($len != $oldlen); return $pattern; } my $prefix = ""; sub addprefix($$) { my ($ptrn, $tmpl) = @_; printf STDERR "%5d: addprefix:$ptrn:$tmpl\n",length($prefix); $ptrn =~ s/0x([0-9a-f]+)\+off/hex($1)+$offset+length($prefix)/eg; $ptrn =~ s/(-?[0-9]+)\+off/$1+$offset+length($prefix)/eg; # print STDERR "addprefix:$ptrn:$tmpl\n"; $prefix = pattern($ptrn).template($tmpl). $prefix; # print STDERR "-->$prefix\n"; } #### sub buildpolygon($$$) { my ($dest,$compressed,$maxlen) = @_; my $looplenbits = 5; my $skiplenbits = 5; my $looplen = 0; my $delim ="CI"; $firstinstr = undef; if ($prefix =~ s/^(IIPIP[CI]*PIICIICI[FP]PPI[FP]PPIIC)//) { $firstinstr = $1; } elsif ($prefix =~ s/^(IIPIF[ICFP](C|F|P|IC)*(IPP)?IICIICI[FP]PPI[FP]PPIIC)//) { $firstinstr = $1; } $compressed .= "$delim"; my $destfix = length($compressed) + length($prefix) + $offset + $dest - 13; for ($i = 0; $i < 2; $i++) { my $copy = pattern("F(?IICF)(?P)(?F)"). template("p<(?FP)IP>" ."tt" . "IPIPIP".("I"x($maxlen-1)).">" ."p<(!qfm1,2!0x7ff)>" ."t" . "tl0fm0,0>")."F"; my $skiplen = length($copy)+$looplen + length(nat($destfix)); if ($skiplen >= (1 << ($skiplenbits-1))) { $skiplenbits = length(nat($skiplen)); $i = -1; } my $skipifend = pattern("!$skiplen:${skiplenbits}$delim") .template(""); if ($firstinstr) { $skipifend =~ s/IICIIC$/$firstinstr/; } $body = "$skipifend$copy"; $looplen = length($body); if ($looplen >= (1 << ($looplenbits-1))) { $looplenbits = length(nat($looplen)); $i = -1; } # print STDERR "$looplen\n"; } $head = pattern("(?IICF)").template("m0,0m0,0"); print STDERR "POLY LOOP LEN: $looplen\n"; print STDERR "$head:$body\n"; $prefix = $head.$body.nat($destfix).$compressed.$prefix; } sub buildreverse($$$) { my $looplenbits = 5; my $skiplenbits = 5; my $destbits = 5; my ($dest,$src,$len) = @_; my $ptrlen = length(nat($len)); my $rptrlen = $ptrlen - 1; my $addlen = (1 << ($rptrlen)); my $ptr1len = $ptrlen+1; $prefix="I"x(20-$ptr1len-1).$prefix; my $looplen = 0; my $loop =""; my $body =""; my $i; for ($i = 0; $i < 2; $i++) { my $destfix = ($dest + $src + $len)/2 - $addlen - $addlen - 1 + $offset + length($prefix); if ($destfix >= (1 << ($destbits-1))) { $destbits = length(nat($destfix)); $i = -1; } my $rdlen = pattern("(!$looplen:$looplenbits)(!${rptrlen}C)P"). template("p<(!$destfix:$destbits(!1!qm0,1qP))!1(!qIqm1,1qP(!1))>". "t"); # my $skiplen = length($rdlen)+$looplen + $ptr1len; # if ($skiplen >= (1 << ($skiplenbits-1))) { # $skiplenbits = length(nat($skiplen)); # $i = -1; # } # my $skipifend = pattern("!$skiplen:${skiplenbits}P") # .template(""); # print STDERR "skip:$skipifend\n"; # print STDERR "rdlen:$rdlen\n"; $body = "$rdlen"; $looplen = length($body); if ($looplen >= (1 << ($looplenbits-1))) { $looplenbits = length(nat($looplen)); $i = -1; } # print STDERR "$looplen\n"; } $head = pattern("(?CFIIC)").template("m0,0m0,0"); print STDERR "PALINDROMER LEN: $looplen\n"; print STDERR "$head:$body\n"; $prefix = $head.$body.nat(2*$addlen-($src - $dest + $len)/2).$prefix; } sub buildmycompressrna(@) { my (@rna) = @_; my %usage = (); for ($i = 0; $i < @rna; $i++) { $usage{$rna[$i]}++; } my @table = sort { $usage{$b} <=> $usage{$a} } keys(%usage); print STDERR "buildcompressedrna: ". join(":",@table)."\n"; $table = join("", map { "III".$_ } @table); $table .= "IFIPPFIPIP"."FIFPPPPPPPPPPPPPPPPPPFFC"; my $tablelen = length($table); my $looplen = 0; my $looplenbits = 5; my $loop = ""; my $i; for ($i = 0; $i < 2; $i++) { # print STDERR "loop:$loop\n"; $looplen = length($loop); if ($looplen >= (1 << ($looplenbits-1))) { $looplenbits = length(nat($looplen)); $i = -1; } $loop = pattern("(?FFC)F(?P)"). template("p<(?FIF(!3!qm0,1)?FFC)>tm0,0"); # print STDERR "$looplen\n"; $loop = $loop.pattern("(!$looplen:$looplenbits)(?FFC)(?P)") .template("p<(!qIqIqIqm0,2!qIqm0,2(!10))>tm0,1"); } my $head = pattern("(!$looplen)").template("m0,0m0,0"); print STDERR "$head : $loop : $table\n"; my %revtable; for ($i = 0; $i< @table; $i++) { $revtable{$table[$i]} = $i; } my $compress = join("", map {nat($revtable{$_})} @rna); $compress =~ s/^(P{3,18})/"F".nat(length($1)-3)/e; while ($compress =~ s/P(P{3,18})/"PF".nat(length($1)-3)/e) { # repeat } print STDERR "$compress\n"; $code = $head.$loop.$table.$compress.nat(@table); return $code; } open DNA, "<../source/endo.dna"; $dna = ; close DNA; $newdna = $dna; sub modifydna($$) { my ($start, $patch) = @_; # addprefix("(!$start+off)!".length($patch), "m0,0$patch"); substr($newdna, $offset + $start, length($patch)) = $patch; } my $totalbytes = 0; sub lenencoding($) { my ($len) = @_; my $enc = nat($len); $enc =~ s/^C//; $enc =~ s/IC/F/g; $enc =~ tr/CIPF/ICFP/; return $enc; } sub distencoding($) { my ($len) = @_; my $enc = nat($len); $enc =~ s/IC/F/g; $enc =~ tr/CIPF/ICFP/; return $enc; } sub skipencoding($) { my ($skip) = @_; my $distpatt; $i = ($skip & 1) - 1; do { $i+=2; $distpatt = distencoding(($skip-$i-1)/2); } while (length($distpatt) > $i); $padding = "C"x($i-length($distpatt)); $distpatt =~ s/F$/${padding}F/; return $distpatt; } sub offlenpattern($$$) { my ($distance, $start, $pattlen) = @_; my $natpattlen = lenencoding($pattlen); my $skip; my $i; if ($distance < 0) { $skip = - $distance; $distpatt = distencoding(($skip-1)/2); $i = length($distpatt); } else { $skip = $distance - length($natpattlen); $distpatt = skipencoding($skip); $i = length($distpatt); $skip -= $i; } printf STDERR "%06x:%03x -> %06x %2d+%2d+%3d bytes %5d total\n", $start-$offset, $pattlen, $skip, $i,length($natpattlen),$pattlen, $totalbytes +=$i+length($natpattlen)+$pattlen; die "skip too small" if $skip < 0; return $distpatt.$natpattlen. substr($newdna, $start, $pattlen); } sub buildmodifications() { my $tail1lenbits = 5; my $looplenbits = 5; $firstinstr = undef; if ($prefix =~ s/^(IIPIP[CI]*PIICIICI[FP]PPI[FP]PPIIC)//) { $firstinstr = $1; } elsif ($prefix =~ s/^(IIPIF[ICFP](C|F|P|IC)*(IPP)?IICIICI[FP]PPI[FP]PPIIC)//) { $firstinstr = $1; } my @difflist = map { length($_) } (split /([^\0])/, ($newdna ^ $dna)); pop @difflist; my (@offsets, @lengths); my $pos = 0; while (@difflist) { my $off = shift @difflist; my $len = shift @difflist; $pos += $off; push @offsets, $pos; push @lengths, $len; printf STDERR "%03d %06x:%03x\n", $#offsets,$pos-$offset,$len; $pos += $len; } my ($i, $j, $k); my (@best, @cost, @bestcost, @skipoffset, @limit); my $beststart; # # $cost[$i][$o][$j] = # of bytes to encode from $offsets[$i]-$o to end # if current patch end is $j (without skip) # $bestcost[$i] = min # of bytes to encode from $i to end (without skip) # $bestcost[$#offsets+1] = 0; for ($i = $#offsets; $i >= 0; $i--) { $bestcost[$i] = $offsets[$#offsets] + $lengths[$#offsets] - $offsets[$i] + 24; $last[$i] = $i; $first[$i] = $i; for ($o = 0; $o < 3 && ($i == 0 || $o < $offsets[$i] - $offsets[$i-1]); $o++) { for ($j = $i; $j < @offsets; $j++) { my $len_ij = $offsets[$j]+$lengths[$j]-$offsets[$i] + $o; $len_ij++ unless ($len_ij & 1); my $lencost_ij = length(lenencoding($len_ij)); next if $len_ij + $bestcost[$j+1] + $lencost_ij > $bestcost[$i]+24; my ($cost_j, $best_k, $best_o2); if ($j == $#offsets) { $cost_j = 0; $best_k = 0; $best_o2 = 0; } else { $cost_j = 24+$bestcost[$j+1]; $best_k = 0; for ($o2 = 0; $o2 < 3 && $o2 < $offsets[$j+1] - $offsets[$j]; $o2++) { for ($k = $first[$j+1]; $k < $last[$j+1]; $k++) { my $skip = $offsets[$j+1] - $o2 - $offsets[$i] + $o - $skipoffset[$j+1][$o2][$k]; print STDERR " $i-$o:$j:-$o2:$k skip $skip cost $cost[$j+1][$k]\n"; next if !$cost[$j+1][$o2][$k]; last if $skip <= 1; my $skipcost = length(skipencoding($skip)); my $cost_jk = $cost[$j+1][$o2][$k] + $skipcost; print STDERR " $i-$o:$j:-$o2:$k costj = $cost[$j+1][$o2][$k] + $skipcost = $cost_jk"; if ($cost_jk < $cost_j) { $cost_j = $cost_jk; $best_k = $k; $best_o2 = $o2; print STDERR "!"; } print STDERR "\n"; } } if (!$best_k) { $first[$i]++ if ($first[$i] == $j); next; } } $cost[$i][$o][$j] = $lencost_ij + $len_ij + $cost_j; $skipoffset[$i][$o][$j] = $len_ij + $lencost_ij; $best[$i][$o][$j] = [$best_k, $best_o2]; print STDERR "$i-$o:$j $lencost_ij + $len_ij + $cost_j = $cost[$i][$o][$j]"; if ($cost[$i][$o][$j] < $bestcost[$i]) { $bestcost[$i] = $cost[$i][$o][$j]; $beststart = [$j,$o] if $i == 0; print STDERR "!"; } print STDERR "\n"; $last[$i] = $j+1 if $last[$i] < $j+1; } } } # print STDERR join("\n", (map { join(":", @{$_}) } @cost))."\n"; $i = 0; my ($j,$o) = @{$beststart}; my $lastoffset = 0; my $lastoffset = 0; print STDERR "BESTPATH: "; while ($i < $#offsets) { my $curroffset = $offsets[$i]-$o; my $currlen = $offsets[$j]+$lengths[$j]-$offsets[$i]+$o; $currlen++ unless ($currlen & 1); print STDERR "$i-$o "; $distance = $curroffset - $lastoffset - $lastlen; push @info, [$distance, $curroffset, $currlen]; $lastoffset = $curroffset; $lastlen = $currlen; $k = $best[$i][$o][$j][0]; $o = $best[$i][$o][$j][1]; $i = $j+1; $j = $k; } print STDERR "$i\n"; my ($dummy, $curroffset, $currlen) = @{shift @info}; for ($i = @info - 1; $i>= 0; $i--) { $prevlen = $i ? $info[$i-1][2] : $currlen; $pattern = offlenpattern($info[$i][0] - $info[$i][2] + $prevlen, $info[$i][1], $info[$i][2]).$pattern; $info[$i][0] = length($pattern); } my $unique = ""; my %next; $next{"I"}="C"; $next{"C"}="F"; $next{"F"}="P"; unshift @info, [length($pattern), $curroffset, $currlen]; { next_unique: if ($unique =~ /^F*$/) { $unique = "I" x (length($unique)+1); $distance = $curroffset + length($pattern) + length($prefix) + length($unique); $startpos = 0; if (($distance & 1) == 0) { $distance--; $startpos++; } $searchpattern = offlenpattern(-$distance, $curroffset, $currlen).$pattern; shift @info; unshift @info, [length($searchpattern), $curroffset, $currlen]; } else { $unique =~ s/^(F*)([IC])/"I" x length($1).$next{$2}/ge; } $pos = $startpos; for ($i = 0; $i < @info; $i++) { $offs = 24 - length(nat($pos)); $patt = substr($searchpattern, -$info[$i][0]); goto next_unique if (substr($patt, $offs, length($unique)) eq $unique); $pos = $info[$i][0]+$info[$i][1]+$info[$i][2]+length($unique); } } $pattern .= $unique; for ($i = 1; $i < @info; $i++) { $patt = substr($pattern, -$info[$i][0]-length($unique)); $patt =~ s/^([^F]*F)([^F]*F)//; printf STDERR "%06x:%03x %s %s %s\n", $info[$i][1]-$offset, $info[$i][2], $1, $2, substr($patt,0,$info[$i][2]); } # add pattern for first entry and add dummy P entry. $distance = $curroffset + length($pattern) + length($prefix); my $dummy = "P"; if (($distance & 1) == 0) { $distance--; $dummy = "CP"; } $pattern = $dummy.offlenpattern(-$distance, $curroffset, $currlen).$pattern; my $looplen = 0; my $body =""; my $loop = ""; for ($i = 0; $i < 2; $i++) { # print STDERR "loop:$loop\n"; my $taillen = length($loop)+$looplen; $taillen += length(nat(length($dna)-$difflist[$#difflist])); if ($taillen >= (1 << ($tail1lenbits-1))) { $tail1lenbits = length(nat($taillen)); $i = -1; next; } $body = pattern("!$taillen:${tail1lenbits}$unique").template(""); if ($firstinstr) { $body =~ s/IICIIC$/$firstinstr/g; } # print STDERR "body:$body\n"; $looplen = length($body.$loop); if ($looplen >= (1 << ($looplenbits-1))) { $looplenbits = length(nat($looplen)); $i = -1; } # print STDERR "$looplen\n"; $loop = pattern("F(?IICF)(?P)(?F)(?F)") .template("p<(!qCqfm1,3)(!qfm0,1!qCqfm1,2)!qCqfm1,3>". "t")."F"; } my $looptail = substr($loop, -5); my $head = pattern("(?IICF)").template("m0,0m0,0"); print STDERR "$head : $body : $loop : ... : $unique\n"; $prefix = $head.$body.$loop.$pattern.$prefix; print STDERR "Patch Code: ".length($head.$body.$loop.$unique)."\n"; # print STDERR "$pattern\n"; } sub buildnegate($$) { my ($src, $len) = @_; my $tail1lenbits = 5; my $looplenbits = 5; $src = $src - 13 + $offset + length($prefix); my $looplen = 0; my $body =""; my $loop = ""; my $i; for ($i = 0; $i < 2; $i++) { # print STDERR "loop:$loop\n"; my $taillen = length($loop)+$looplen; if ($taillen >= (1 << ($tail1lenbits-1))) { $tail1lenbits = length(nat($taillen)); $i = -1; next; } $body = pattern("!$taillen:$tail1lenbits".nat(13*$len)).template(""); # print STDERR "body:$body\n"; $looplen = length($body.$loop); if ($looplen >= (1 << ($looplenbits-1))) { $looplenbits = length(nat($looplen)); $i = -1; } # print STDERR "$looplen\n"; $loop = pattern("(!$looplen:$looplenbits)(?P)") .template("p<(!$src(!qm0,1!13))(!11)>". "t". "t". "t". "t". "tm0,0IIIIIIIIII". ">m0,1". ">l1m0,1". ">l0m0,1". ">"); } my $head = pattern("(!$looplen)").template("m0,0m0,0"); print STDERR "$head : $body : $loop \n"; $prefix = $head.$body.$loop."P".$prefix; } sub compress($) { my $prefix = $_[0]; print STDERR "Uncompressed: ".length($prefix); $prefix =~ s/^IIPIF[ICFP]((C|F|P|IC)*)IICIICI[FP]PPI[FP]PPIIC// or die "Illegal start"; $startpatt = antiquote($1); $prefix = reverse($prefix); $prefix =~ s/I/00/g; $prefix =~ s/C/1/g; $prefix =~ s/F/010/g; $prefix =~ s/P/011/g; my $odd = length($prefix) & 1; printf STDERR " Compressed: ".(length($prefix)/2); $prefix .= "0" if $odd; $prefix =~ s/([01])([01])/chr(2*$1+$2)/eg; $prefix =~ tr/\0-\003/ICFP/; my $unique = "I"; my %next; $next{"I"}="C"; $next{"C"}="F"; $next{"F"}="P"; $sum = $prefix; while ($unique =~ /^I/ || $unique =~ /II/ || $unique =~ /CCI/ || $sum =~ /$unique/ ) { if ($unique =~ /^F*$/) { $unique = "I" x (length($unique)+1); } else { $unique =~ s/^(F*)([IC])/"I" x length($1).$next{$2}/ge; } $sum = $prefix.substr($unique,0,length($unique)-1); } print STDERR " Unique: $unique "; # st0: I->I0 C->1 F->C2 P->CC0 # st1: I->F2 C->FC0 F->P2 P->PC0 # st2: I->I2 C->IC0 F->F0 P->P0 my $tmpl0="IIC".pattern("(?IFIC)"); my $tmpl1=pattern("(?$unique)").template("m0,0"); $tmpl0 =~ s/IIC$//; $tmpl1 =~ s/IIC$//; my @stmtable = ([ "II", "II" ], [ "IC", "C" ], [ "IF", "FC" ], [ "IP", "ICC" ], [ "CI", "FF" ], [ "CC", "ICF" ], [ "CF", "FP" ], [ "CP", "ICP" ], [ "FI", "FI" ], [ "FC", "ICI" ], [ "FF", "IF" ], [ "FP", "IP" ]); my $lastentry = ($odd ? "F" : "I").substr($unique,0,1); for ($i = 0; $i < @stmtable; $i++) { if ($stmtable[$i][0] eq $lastentry) { my $temp = $stmtable[$i]; $stmtable[$i] = $stmtable[$#stmtable]; $stmtable[$#stmtable] = $temp; last; } } my $buildstm = pattern("(?FF)").template("m0,0m0,0"). pattern("?FFC!0P(?FFC)").template("m0,0m0,0"). pattern("FF(?FF)C(!2)(!1)(?II)(?PPPIIC)"). template("m0,0m0,0Cm0,4pIFPPIFPPm0,2IFPCPm0,3C"). "FFC". join("", map { ${$_}[0].quote(${$_}[1])."II" } @stmtable). "P". pattern("?FFC?FFC!0".($odd ? "F": "I").$unique."(?$startpatt)").template("m0,0m0,0")."FFCI"; print STDERR " Total: ".(length($buildstm)+length($unique)+length($prefix))."\n"; return $buildstm.$prefix.$unique; } sub skipcode($$) { my ($from,$to) = @_; my $patch = lenpattern("!".($to-$from)."-len",""); print STDERR "skipcode($from,$to): $patch\n"; modifydna($from, $patch); } sub skipcodefix($$$) { my ($from,$to,$bits) = @_; my $patch = lenpattern("!".($to-$from)."-len:$bits",""); print STDERR "skipcode($from,$to): $patch\n"; modifydna($from, $patch); } sub backskipcode($$$) { my ($from,$taillen,$to) = @_; $addr = $to + $taillen; $codelen = $from - $to; my $patch = lenpattern("(!$addr-len(!$codelen+len))","m0,0m0,1"); modifydna($from, $patch); } sub ecc($$) { $both = $_[0].$_[1];return "II" if ($both =~ /[ICF]III/ || $both =~ /I[ICF]II/ || $both =~ /II[ICF]I/ || $both =~ /III[ICF]/);return "IC" if ($both =~ /[ICF]CPF/ || $both =~ /I[ICP]PF/ || $both =~ /IC[CFP]F/ || $both =~ /ICP[IFP]/);return "IF" if ($both =~ /[ICF]FCP/ || $both =~ /I[IFP]CP/ || $both =~ /IF[ICP]P/ || $both =~ /IFC[CFP]/);return "IP" if ($both =~ /[ICF]PFC/ || $both =~ /I[CFP]FC/ || $both =~ /IP[IFP]C/ || $both =~ /IPF[ICP]/);return "CI" if ($both =~ /[ICP]IFP/ || $both =~ /C[ICF]FP/ || $both =~ /CI[IFP]P/ || $both =~ /CIF[CFP]/);return "CC" if ($both =~ /[ICP]CCC/ || $both =~ /C[ICP]CC/ || $both =~ /CC[ICP]C/ || $both =~ /CCC[ICP]/);return "CF" if ($both =~ /[ICP]FPI/ || $both =~ /C[IFP]PI/ || $both =~ /CF[CFP]I/ || $both =~ /CFP[ICF]/);return "CP" if ($both =~ /[ICP]PIF/ || $both =~ /C[CFP]IF/ || $both =~ /CP[ICF]F/ || $both =~ /CPI[IFP]/);return "FI" if ($both =~ /[IFP]IPC/ || $both =~ /F[ICF]PC/ || $both =~ /FI[CFP]C/ || $both =~ /FIP[ICP]/);return "FC" if ($both =~ /[IFP]CIP/ || $both =~ /F[ICP]IP/ || $both =~ /FC[ICF]P/ || $both =~ /FCI[CFP]/);return "FF" if ($both =~ /[IFP]FFF/ || $both =~ /F[IFP]FF/ || $both =~ /FF[IFP]F/ || $both =~ /FFF[IFP]/);return "FP" if ($both =~ /[IFP]PCI/ || $both =~ /F[CFP]CI/ || $both =~ /FP[ICP]I/ || $both =~ /FPC[ICF]/);return "PI" if ($both =~ /[CFP]ICF/ || $both =~ /P[ICF]CF/ || $both =~ /PI[ICP]F/ || $both =~ /PIC[IFP]/);return "PC" if ($both =~ /[CFP]CFI/ || $both =~ /P[ICP]FI/ || $both =~ /PC[IFP]I/ || $both =~ /PCF[ICF]/);return "PF" if ($both =~ /[CFP]FIC/ || $both =~ /P[IFP]IC/ || $both =~ /PF[ICF]C/ || $both =~ /PFI[ICP]/);return "PP" if ($both =~ /[CFP]PPP/ || $both =~ /P[CFP]PP/ || $both =~ /PP[CFP]P/ || $both =~ /PPP[CFP]/);warn "wrong ecc $both";return substr($both,0,2);} sub correctcode($$) { my ($data,$ecc) = @_; my $result=""; while ($data =~ s/^(..)//) { $dbits = $1; $ecc =~ s/^(..)//; $result .= ecc($dbits,$1); } return $result; } sub rc4($@) { my ($dna,@key) = @_; my @S; my ($j, $i, $t, $out, $keyidx); my $dnaout; $dna =~ tr/ICFP/0123/; for ($i = 0; $i < 256; $i++) { $S[$i] = $i; } $j = 0; $keyidx = 0; for ($i = 0; $i < 256; $i++) { if ($key[$keyidx] == 255) { $keyidx = 0; } $j = ($j + $S[$i] + $key[$keyidx++]) & 255; $t = $S[$i]; $S[$i] = $S[$j]; $S[$j] = $t; } $i = 0; $j = 0; while (length($dna) >= 4) { $i = ($i + 1) & 255; $j = ($j + $S[$i]) & 255; $t = $S[$i]; $S[$i] = $S[$j]; $S[$j] = $t; $out = $S[($S[$i] + $S[$j]) & 255]; $dna =~ s/([0123])([0123])([0123])([0123])//; $out ^= ($1 + 4*$2 + 16*$3 + 64*$4); $dnaout .= ($out & 3).(($out >>2)&3).(($out >>4)&3).(($out >>6)&3); } $i = ($i + 1) & 255; $j = ($j + $S[$i]) & 255; $t = $S[$i]; $S[$i] = $S[$j]; $S[$j] = $t; $out = $S[($S[$i] + $S[$j]) & 255]; while (length($dna)) { $dna =~ s/([0123])//; $dnaout .= (($out & 3) ^ $1); $out >>=2; } $dnaout =~ tr/0123/ICFP/; return $dnaout; } #patch clouds buildreverse(0x60fea4, 0x61181e, 0x1962); #modifydna(0x60fea4, substr(reverse(substr($newdna, $offset+0x61181e, 0x1962)), 0, 0x1962-75)); # set hillsEnabled modifydna(0x3346a,"P"); #modifydna(0x4cd014+57,"PF"); # damage "virus" code before surfaceTransform #print STDERR substr($dna, $offset+0x6d3fee, 315); modifydna(0x6d402c+5,"P"); #skipcode(0x6d3fb5+10, 0x6d412a); # skip everything except surfaceTransform #skipcode(0x4cccfe,0x4cd07d); #skipcode(0x4cd37f+10, 0x4d7215); #patch hill curves #first hill #Old 0 242 -28: 3348 408 7 4 #New optimum 0 218 -20: 1816:412: 8: 4 (9.538964) modifydna(0x6d4573, quote(natfix(218,24))); modifydna(0x6d46b8, quote(natfix(-20,24))); modifydna(0x6d4704, quote(natfix(1816,24))); modifydna(0x6d4897+0x30, quote(natfix(412,24))); modifydna(0x6d48e3+0x30, quote(natfix(8,24))); modifydna(0x6d492f+0x30, quote(natfix(4,24))); #2nd hill: #Old 200 209 -21: 1848 328: 13: 3 #New optimum 50 235 -28: 3348:328: 13: 3 (20.000000) modifydna(0x6d543f, quote(natfix(235,24))); modifydna(0x6d5584, quote(natfix(-28,24))); modifydna(0x6d55d0, quote(natfix(3348,24))); modifydna(0x6d5793, quote(natfix(328,24))); modifydna(0x6d57df, quote(natfix(13,24))); modifydna(0x6d582b, quote(natfix(3,24))); # 3rd hill # New optimum 350 257 0: 0:104: 65: 8 (99.520354) # New optimum 350 257 0: 0:104: 60: 8 (99.520354) # modifydna(0x6d62a7, quote(natfix(257,24))); modifydna(0x6d63ed, quote(natfix(104,24))); modifydna(0x6d6439, quote(natfix(60,24))); modifydna(0x6d6485, quote(natfix(8,24))); # decrypt MU and cow-tail (at run-time) my @mukey = (0x55, 0x56, 0xb1, 0x3c, 0x81, 0x67, 0xb3, 255); my $mudummy = 0x480 - 9*(@mukey); my @cowtailkey = (0xb9, 0xb5, 0xb4, 0xb6, 255); my $cowtaildummy = 0x480 - 9*(@cowtailkey); # set giveMeAPresent to cowtailkey # since the key often breaks the CI end marker, we replace it with CF in # the key; crypt only takes numeric values of key. $cowtailkeybin = join('', map {natfix($_,9)} @cowtailkey); $cowtailkeybin =~ s/CI/CF/g; modifydna(0x00005d, $cowtailkeybin); # patch address from vmu-code to cow-tail # do not patch length, because encrypting too much does not hurt. modifydna(0x63a773+0x31, quote(natfix(0x4aa77d,24))); #.natfix(0xe51,24))); # skip to goodvibrations skipcode(0x63aa9b, 0x63acea); # This is a hack to make the patch one larger than necessary # which will overall shrink the patch. #substr($dna, $offset + 0x63aa9f, 1) = "P"; # patch key (in initlocals) modifydna(0x63a567, quote(join('', map {natfix($_,9)} @mukey))); # patch address from help-beautiful-numbers to charInfo_Tempus-Bold-Huge_M # do not patch length, because encrypting too much does not hurt. # It changes fontTable_Tempus-Small and other font tables but the only # drawing command with these fonts happened just before. modifydna(0x63b668+0x31, quote(natfix(0x7a97b,24))); #.natfix(0x145c,24))); # skip to main skipcode(0x63b990, 0x63bc8f); ################################# # WEED ################################# # weed seed = 8128 modifydna(0xc7dc0, natfix(8128,24)); ################################# # CARGOBOX ################################# # Patch rna code in cargobox ma->yw modifydna(0x21f149, "CF"); modifydna(0x21f1ca, "P"); # Switch on daylight modifydna(0x00050f, "F"); ################################ # PEARTREE ################################ # patch return in appletree to jump to pear tree modifydna(0x3c9e30+132, quote(natfix(0x589a07,24))); ################################ # RIVER ################################ # swap mkGoldFish[LR]_adaptation #72035a(001f46): PARAM: drawGoldFishL_adaptation #72038a(001f76): PARAM: drawGoldFishR_adaptation modifydna(0x72035a, natfix(0x7287f2,24)); modifydna(0x72038a, natfix(0x7289d2,24)); # patch coords of fish in adaptation modifydna(0x71cc3f, natfix(18,24)); # patch ptr to emptyBox (param of threeFish_adaptation) in goldenfish modifydna(0x71cf0f, natfix(0x71e294,24)); ################################ # WHALE ################################ # patch whale coords modifydna(0x4d535a, quote(natfix(0x187+19,24))); modifydna(0x4d53a6, quote(natfix(0xb0+24,24))); # patch whale face modifydna(0x4d54b6+43, "IPP"); #modifydna(0x26654d+0x31-6, "C"); ################################ # BMU ################################ # Draw endo but not as a shadow! # skip the first addbmp and the clip comp at the end # Also skip the code that draws endo as weird cow, duck, ocaml, mlephant etc. skipcodefix(0xdaf2d, 0xdb0fb,25); skipcode(0x0df46c+10, 0x0df78c); ################################ # CLOUDS ################################ #draw clouds for weather == 0 modifydna(0x6f9e0b+57, quote(natfix(0,24))); #don't set cloudy #60ff3d(000099): cloudy := true # modify address to cloudy (modifies unused part of biomorphPerturb) #modifydna(0x60fea4 + 0x99 + 5, "I"); # (do it in "duolc" though) modifydna(0x61181e + 0x001962 - 0x99 - 5, "I"); #patch cloud size modifydna(0x5c963d, quote(natfix(10,24))); modifydna(0x5c99dd, quote(natfix(20,24))); #patch cloud positions modifydna(0x5c9164, quote(natfix(25,24))); modifydna(0x5c94fa, quote(natfix(55,24))); modifydna(0x5c989a, quote(natfix(30,24))); ######################### # fix motherduck ######################### # there is one coordinate in the polygon wrong. modifydna(0x2c932e, "C"); ####### # patch ufo ####### # set coords of water modifydna(0x653601+0x30, quote(natfix(55-1,24))); modifydna(0x65364d+0x30, quote(natfix(42-27,24))); # set fill point to be the same as for ufo cup modifydna(0x52dce5+0x30, quote(natfix(84 - (55-1),24))); modifydna(0x52dd31+0x30, quote(natfix(41 - (42-27),24))); # patch rna in water to include 2*turn modifydna(0x52de36+10, "IIIPFFFFFP"); modifydna(0x52de4a+2, natfix(0xbca - 0xae9 - 160, 25)); modifydna(0x52de4a+147, "IIIPFFFFFPIIC"); print STDERR "RETURN WATER: ".substr($newdna, $offset+0x52de4a, 200)."\n"; # patch rna after ufo-cup to revert 2*turn modifydna(0x654c9d, "IIIPFFFFFPIIIPFFFFFP"); # L L modifydna (0x654cf0+0x30, quote(natfix(164-271+2048,24))); modifydna (0x654d3c+0x30, quote(natfix(420-293,24))); $spiro = 0x641483; $spirolen = 0x63a4fd + 0x1303b - $spiro; # patch return address of setOrigin to jump to part of main (spirograph) # This also takes care of the missing comp modifydna(0x654d88+132, quote(natfix($spiro,24) .natfix($spirolen,24))); #modifydna(0x654e41+32, natfix($spiro,25)); #modifydna(0x654e41+62, natfix($spirolen,25)); #modifydna(0x654e41+92, natfix($programsize - $spiro - $spirolen,25)); #replace call to resetOrigin with jump, so that it will return to caller. #modifydna(0x654efa+2, natfix(0x2d08-0x21b0-132-3,25)); #modifydna(0x654efa+132, "IIC"); #$remfunc = 0x2d08 - (0x1f53+20); #$patch = lenpattern("!$remfunc-len(!$spiro(!$spirolen))","m0,0m0,1"); #modifydna(0x654c9d+20, $patch); #patch size of spirographs #modifydna (0x641a0a+0x30, quote(natfix(1,24))); #modifydna (0x642113+0x30, quote(natfix(1,24))); #modifydna (0x642826+0x30, quote(natfix(1,24))); ##### # patch spirograph ##### #patch spirograph to ignore multiplier #this damages the pop instruction so that it does not store the value. modifydna (0x6f4f20+57+18, "IC"); modifydna (0x6f51b4+57+18, "IC"); # Patch ret addr of resetOrigin to jump to another resetOrigin # (we still need one from ufo). #modifydna(0x654efa+2, natfix(0x2d08-0x21b0-132-3,25)); #modifydna(0x654efa+132, "IIC"); skipcode(0x642b60+10, 0x642fe4); #modifydna(0x642aa7+132, quote(natfix(0x642fe4, 24).natfix(0x1303b-0x8ae7,24))); #replace it with a jump and a comp modifydna(0x642fe4+2, natfix(0x1303b-0x8ae7-132-3,25)); modifydna(0x642fe4+132, "IIC"); # skip anticompressant #skipcode(0x63bdc8, 0x63be81); ## Make wind # old code that patches sine and cosine table # new code just sets polarAngleIncr #addprefix("(!0xc4da8+off)(!120)(!6024)", "m0,0m0,2m0,1"); #addprefix("(!0xc65a8+off)(!120)(!6024)", "m0,0m0,2m0,1"); ##### # patch flowerbed ##### modifydna(0x45acfd+0x30, quote(natfix(34,24))); modifydna(0x45ad49+0x30, quote(natfix(0,24))); modifydna(0x45b17c+0x30, quote(natfix(0,24))); modifydna(0x45b1c8+0x30, quote(natfix(0,24))); modifydna(0x45b605+0x30, quote(natfix(58,24))); modifydna(0x45b651+0x30, quote(natfix(12,24))); modifydna(0x45ba8e+0x30, quote(natfix(17,24))); modifydna(0x45bada+0x30, quote(natfix(24,24))); #patch SUN # this is shorter than fixing the code programmatically $flower = substr($dna,$offset+0x224fb1, 0x0006e0); #0x206d37 $sunflower = substr($dna,$offset+0x20742f, 0x0006e0); $flower =~ tr/ICFP/\0\001\002\003/; $sunflower =~ tr/ICFP/\0\001\002\003/; $sunflower ^= $flower; $sunflower =~ tr/\0\001\002\003/ICFP/; $sunflower = substr($sunflower, 0, 0x0006e0-75); modifydna(0x206d37, $sunflower); # patch cowspot $cowspot = correctcode(substr($dna,$offset+0x0d985b, 0xb34), substr($dna,$offset+0x0da3a7, 0xb34)); $cowspot = substr($cowspot, 0, 0xb34-75); modifydna(0x0d985b, $cowspot); #call ecc (this is actually longer than just fixing the few bases). # 200 bytes vs. 101 bytes # #addprefix("(?IFPICFPPCCC(?IFPICFPPCCC)?IFPICFPPCFIPP)", # "m0,0".nat(0x5b7bf3).nat(0xe8de)."m0,1". # natfix(0xb34,24).natfix(0xda3a7,24).natfix(0xd985b,24)); #skip balloon #skipcode(0x6f31b6,0x6f4b58); #skip everything except balloon #skipcode(0x4ccd08, 0x4d5cca); #4d5d09(00900b): stack_18:18 := #255:18 x #4d5d55(009057): stack_0:18 := #305:18 y #6f37ef(000639): stack_48:18 := #145:18 width #6f383b(000685): stack_30:18 := #116:18 height #x 198 - 299 wd 103 #y 324 - 493 ht 169 modifydna(0x4d5d39, quote(natfix(198,24))); modifydna(0x4d5d85, quote(natfix(324,24))); modifydna(0x6f381f, quote(natfix(101,24))); modifydna(0x6f386b, quote(natfix(169,24))); #skipcode(0x6f3abe,0x6f46d1+20); #6f4580(0013ca): stack_18:18 := #106:18 #fill x -> 74 modifydna(0x6f45b0, quote(natfix(74,24))); my %shortcuts = ("bk" => "PIPIIIC", "rd" => "PIPIIIP", "gn" => "PIPIICC", "yw" => "PIPIICF", "be" => "PIPIICP", "ma" => "PIPIIFC", "cn" => "PIPIIFF", "we" => "PIPIIPC", "tt" => "PIPIIPF", "oq" => "PIPIIPP", "rs" => "PIIPICP", "M" => "PIIIIIP", #move "L" => "PCCCCCP", #turn left "R" => "PFFFFFP", #turn right "S" => "PCCIFFP", #start (mark) "E" => "PFFICCP", #end (line) "F" => "PIIPIIP", #fill "addbmp" => "PCCPFFP", "comp" => "PFFPCCP", "clip" => "PFFICCF"); my @poly = (45,51, 43,46, 41,40, 40,32, 42,19, 45,14, 47,11, 53,5, 58,3, 64,1, 70,0, 71,1, 81,4, 90,10, 94,13, 100,22, 101,27, 99,39, 98,40, 96,43, 93,48, 91,50, 84,54, 80,57, 69,59, 55,59, 48,58, 42,60, 38,65, 36,67, 36,79, 38,82, 41,87, 43,93, 48,99, 45,104, 43,105, 39,112, 38,112, 35,115, 23,128, 3,145, 3,148, 4,153, 7,158, 11,162, 16,163, 17,164, 22,164, 22,165, 21,165, 19,169, 16,167, 15,167, 10,165, 1,156, 0,153, 0,144, 7,138, 42,103, 44,100, 41,94, 38,90, 34,84, 34,81, 31,78, 30,75, 30,65, 36,58, 39,56, 41,54); @poly = (@poly[110..$#poly],@poly[0..109]); if (1) { my ($x,$y,$i); $x = $poly[0]; $y = $poly[1]; for ($i = 2; $i < @poly; $i+=2) { $poly[$i] -= $x; $poly[$i+1] -= $y; $x += $poly[$i]; $y += $poly[$i+1]; } my $len = @poly; push @poly, $x-$poly[0],$y-$poly[1]; unshift @poly, $len/2; $compressed = ""; $maxlen = 0; modifydna(0x6f3b9e, quote(natfix(shift (@poly), 12))); for ($i = 0; $i < @poly; $i++) { my $from = substr($dna, $offset+ 0x6f3b9e + 13*$i, 13); my $to = $poly[$i]+1; if ($to < 0) { my $nat .= nat(-$to); $maxlen = length($nat) if (length($nat) > $maxlen); $nat =~ tr/IC/CI/; $compressed .= $nat; } else { $compressed .= nat($to); } # modifydna(0x6f3b9e+13 + 13*$i, quote(natfix($poly[$i],12))); } $compressed =~ s/IC/F/g; $compressed =~ tr/ICFP/CIPF/; print STDERR "POLY COMPRESSED: ".length($compressed)."\n"; buildpolygon(0x6f3b9e+13, $compressed, $maxlen); # print "$prefix"; # exit; } else { my $startx = shift @poly; my $starty = shift @poly; push @poly, $startx, $starty; push @poly, 0,0; my @balloonrna = (("M")x $startx, "R", ("M")x$starty, "S"); my $lastx = $startx; my $lasty = $starty; my $dir = 2; while (@poly) { my $x = shift @poly; my $y = shift @poly; $x -= $lastx; $y -= $lasty; next if (!$x && !$y); if ($x && $dir == ($x > 0 ? 3 : 1)) { # wrong direction; start with y. $newdir = ($y > 0 ? 2 : 0); push @balloonrna, ((($newdir-$dir) & 3) == 1 ? "R" : "L"); $dir = $newdir; } elsif ($y && $dir == ($y > 0 ? 0 : 2)) { # wrong direction; start with x. $newdir = ($x > 0 ? 1 : 3); push @balloonrna, ((($newdir-$dir) & 3) == 1 ? "R" : "L"); $dir = $newdir; } if ($dir & 1) { push @balloonrna, ("M") x abs($x); if ($y) { $newdir = ($y > 0 ? 2 : 0); push @balloonrna, ((($newdir-$dir) & 3) == 1 ? "R" : "L"); push @balloonrna, ("M") x abs($y); $dir = $newdir; } } else { push @balloonrna, ("M") x abs($y); if ($x) { $newdir = ($x > 0 ? 1 : 3); push @balloonrna, ((($newdir-$dir) & 3) == 1 ? "R" : "L"); push @balloonrna, ("M") x abs($x); $dir = $newdir; } } $lastx += $x; $lasty += $y; push @balloonrna, "E" if (@poly > 0); push @balloonrna, "S" if (@poly > 2); } push @balloonrna, "R" if ($dir == 0); push @balloonrna, "L" if ($dir == 2); push @balloonrna, "L","L" if ($dir == 3); $dir = 0; print STDERR join ":", @balloonrna; $balloon = buildmycompressrna( map { $shortcuts{$_} } @balloonrna); modifydna(0x6f3ad2, $balloon); skipcode(0x6f3ad2+length($balloon), 0x6f4541); } #modifydna(0x6f46d1,"I"x20); #print $balloon; #exit; #6f4a25(00186f): stack_0:480 := 'L' modifydna(0x6f4a70, quote(natfix(0x94,9))); #$mu = join "", map{nat($_)} #(split ('',"0010000000231".("0"x20)."210040020100040021". # "0000000300241".("0"x13)."2310000000231".("0"x22). # "2410021004002100213021302100000300021000240130210003002". # "1000040023054040100030021020400213021". # "0004023000302". # "04010402102100000400210300021000300210003021". # ("0"x12)."203014".("0"x21)."2305". # "87774040014".("0"x22)."2".("0"x10)."3014020004001200004001200012". # "0000003012000102000400120001204000041020401020000400000001". # ("0"x14)."233".("0"x20). # "14020030000120400120001200004000120030123030000123". # ("0"x21)."300"), 20); # #modifydna(0x079ee5+9, natfix(length($mu),24)); #modifydna(0x079ee5+9+24, $mu); #6f498d(0017d7): stack_498:18 := #98:18 #6f49d9(001823): stack_480:18 := #20:18 modifydna(0x6f49bd, quote(natfix(56,24))); modifydna(0x6f4a09, quote(natfix(2,24))); # rotate wind mill. (polarAngleIncr) modifydna(0xc91e0, natfix(5,24)); #patch VMU (vmuMode = 31, set registration key) to draw caravan #skipcode(0x23bd63, 0x23c2aa); modifydna(0x03346b,natfix(31,24)); #modifydna(0x23bd63+2,natfix(0x000241- 0x0000c6,25)); modifydna(0x033483, join("", map {natfix($_,9) } (0x96,0x64,0x63,45,0x56,0x46,45,0x82,0x41,0x55,0x44,45,0x89,0x89,255))); # set VMU coordinates modifydna(0x4d08d3, quote(natfix(267,24))); modifydna(0x4d091f, quote(natfix(210,24))); ################################ # GRASS layout ################################ #patch biomorph array #modifydna(0x0c9229 + 24* 3,natfix(-16,24)); #modifydna(0x0c9229 + 24* 9,natfix( 7,24)); #modifydna(0x0c9229 + 24*21,natfix( 4,24)); #patch grass directly modifydna(0x4cd78d + 10* 3, quote(natfix(0x47,9))); # El *g*asto modifydna(0x4cd78d + 10* 9, quote(natfix(0x69,9))); # *z*iempre se modifydna(0x4cd78d + 10*21, quote(natfix(0x49,9))); # v*i* mas verde... # patch enableBioMorph_adaptor #modifydna(0x71c4ef+24, natfix(0x6ff34f,24)); # fix bioMul #modifydna(0x719153, join '', map {natfix($_,24)} # 26*24, # 0x6fce9c, # activateAdaptationTree # 0x713860, # caseVar1 # 2*24, # 0x6fce9c, # activateAdaptationTree # 0x71077e, # var1_adaptation # 20*24, # 0x6fce9c, # activateAdaptationTree # 0x719633, # apply2_adaptation # 2*24, # 0x6fce9c, # activateAdaptationTree # 0x710436, # bioAdd_adaptation # 2*24, # 0x6fce9c, # activateAdaptationTree # 0x712c3a, # var2_adaptation # 11*24, # 0x6fce9c, # activateAdaptationTree # 0x719633, # apply2_adaptation # 2*24, # 0x6fce9c, # activateAdaptationTree # 0x719153, # bioMul_adaptation # 2*24, # 0x6fce9c, # activateAdaptationTree # 0x71077e, # var1_adaptation # 2*24, # 0x6fce9c, # activateAdaptationTree # 0x712c3a, # var2_adaptation # $programsize - 0x719153 - 26*24 - 48 # ); ##### # patch sun / sky-day-bodies ##### modifydna(0x206d37+19, "C"); modifydna(0x206d37+23, "C"); # copy rna commands from colorSoftYellow for sun # note that with this alignment we can reuse some of the previous command. my $patch = lenpattern("!".(0x6fa5ad-0x6fa52d)."-len:25". "(!".(0xba3-0x7ac+0x5c9ceb).":25(!340:12))", "m0,0m0,1"); modifydna(0x6fa52d, $patch); #skipcode(0x6fa52d, 0x6fa5ad-length($patch)); #my $newstart = 0x206d55-length($patch); #my $newlength = 0x0006e0 - 30 + length($patch); # patch sun: set color #modifydna(0x206d37+30, $patch); # patch addr in call to sun #modifydna(0x6fa75d,natfix($newstart,25)); # patch length in call to sun #modifydna(0x6fa77b,natfix($newlength,25)); ####### # patch printGeneTable (whale-blow) ####### # swap left-right modifydna(0x29bc48+ 424,"IIIPFFFFFP"); modifydna(0x29bc48+ 488,"IIIPCCCCCP"); #skipcodefix(0x2a8825,0x2abd95,25); modifydna(0x2aae98+2, natfix(0x2abd95- 0x2aaee0,25)); modifydna(0x2abd9f + 90, "I"); #return 0 ####### # patch scenario ####### # jump to motherduck (but don't set ducksShown) skipcodefix(0x4cf419,0x4cf46b,25); #modifydna(0x4cf3b0+57, "P"); # disable conditional goto #modifydna(0x4cfdad+57, "P"); # disable chick conditional goto # patch lambda-id with whale-blow my $whaleblow = 0x29bab8; my $whaleblowlen = 0x284bc3 + 0x0272c1 - $whaleblow; modifydna(0x4d1020+32, natfix($whaleblow,25)); modifydna(0x4d1020+62, natfix($whaleblowlen,25)); modifydna(0x4d1020+92, natfix($programsize-$whaleblow-$whaleblowlen,25)); # cooords of whale blow modifydna(0x4d0ecf+0x30, quote(natfix(430-550+2048,24))); modifydna(0x4d0f1b+0x30, quote(natfix(200-595+2048,24))); #modifydna(0x29baf7+ 0x30, quote(natfix(430-45,24))); #modifydna(0x29bb43+ 0x30, quote(natfix(200-275+2048,24))); # patch crater with ufo modifydna(0x4d582e+32, natfix(0x6535b8,25)); modifydna(0x4d582e+62, natfix( 0x2d08 - (0x6535b8-0x652d4a),25)); modifydna(0x4d582e+92, natfix($programsize-0x652d4a - 0x2d08,25)); # patch coords for ufo modifydna(0x4d56dd+0x30, quote(natfix(366,24))); modifydna(0x4d5729+0x30, quote(natfix(250,24))); # jump back to chick #backskipcode(0x4d6606,0xa5f8-0x9908,0x4cfe16); #4d6791(009a93): stack_0:480 := 'Morph Endo!' #4d685b(009b5d): CALL drawString modifydna(0x4d685b, pattern("!".(0x4cccfe+0xa5f8 - 0x4d6914).":25". "(!".(0x4cfe16+50).":25(!". (0x4cccfe+0xa5f8 - 0x4cfe16 -50).":25")); modifydna(0x4d685b+132, "IIC"); #modifydna(0x4d6791+75, quote(natfix(255,9))); #modifydna(0x4d685b+132, quote(natfix(0x4cfe16,24). # natfix(0x4cccfe+0xa5f8-0x4cfe16,24))); #print STDERR "NEW: ".substr($newdna, $offset+ 0x4d6791,200)."\n"; # patch coords for chick modifydna(0x4cfe85, quote(natfix(171,24))); modifydna(0x4cfed1, quote(natfix(410,24))); # jump from chick to output text modifydna(0x4d016b+132, quote(natfix(0x4d6286,24) .natfix(0x4cccfe+0xa5f8-0x4d6286,24))); modifydna(0x4d6316, join("", map {quote(natfix($_,9)) } (0x62,0,0x54,0x56,0x59,0x57,0x48,0x45,0x44,0x0f))); # decrypt cow-tail in source dna my $cowtail = substr($dna, $offset+0x4aa77d, 0x00145c); $cowtail = rc4($cowtail, (0xb9, 0xb5,0xb4,0xb6,255)); # ... patch it ... my $len = 10; my $lenbits = 1; while ($lenbits < length(nat($len))) { $lenbits = length(nat($len)); $patch = pattern("(!$len:$lenbits)").template("m0,0m0,0m0,0"); $len = int((length($patch)+19)/20)*10+50; } $lenbits += (2*$len - 100 - length($patch)); $patch = pattern("(!$len:$lenbits)").template("m0,0m0,0m0,0"); # the ultimative patch :) $patch = "IIPIPICCIIICIIIPIICIICIPIPIIPIPPPIPPPIIC"; # IIIPIPIIPCIIIPIPIIPCIIIPIPIIPCIIIPIPIIPC print STDERR "compress RNA $patch ($len)\n"; $patch = "IIIPIPIIPP".$patch.("IIIPIPIIPP"x2).("IIIPIPIIPF"x1); # insert 7 opaque and 3 transparent #die "Something went wrong: $patch, $len" if (length($patch) != 2*$len-60); substr($cowtail, 20+40, length($patch)) = $patch; # ... and encrypt it again. $cowtail = rc4($cowtail, (0xb9, 0xb5,0xb4,0xb6,255)); modifydna(0x4aa77d, $cowtail); # ignore integrity check modifydna(0xdba7c+57, "PP"); #skipcode(0xdbac4, 0xdbae5); #modifydna(0x60fea4, substr(reverse(substr($newdna, $offset+0x61181e, 0x1962)), 0, 0x1962-75)); #modifydna(0x61181e, substr($dna, $offset+0x61181e, 0x1962)); buildmodifications(); print STDERR "Total: ".length($prefix)."\n"; print $prefix;