#!/usr/bin/perl

use DBI;

my $dbh=DBI->connect("dbi:SQLite:dbname=katawa.sqlite","","");
$|=1;

########################################################
# First process imachine which give scene succession
########################################################

$dbh->do("DROP TABLE story");
$dbh->do("CREATE TABLE story (id INTEGER, type INTEGER, name TEXT, param INTEGER, next INTEGER)");

my $pc=1;
my $iflvl=0;
my @ifout=();
my @ifalt=();
my %labels=();
my $instr;
my $p1;
my $p2;
my $p3;
my $p4;

print "Compiling Sequence\n";

open(I,"<imachine.rpy");

my $stmi=$dbh->prepare("INSERT INTO story(id,type,name,param,next) VALUES (?,?,'',0,0)");
my $stmin=$dbh->prepare("INSERT INTO story(id,type,name,param,next) VALUES (?,?,?,0,0)");
my $stmip=$dbh->prepare("INSERT INTO story(id,type,name,param,next) VALUES (?,?,'',?,0)");
my $stminp=$dbh->prepare("INSERT INTO story(id,type,name,param,next) VALUES (?,?,?,?,0)");

my $stmiq=$dbh->prepare("INSERT INTO story(id,type,name,param,next) VALUES (?,?,'',0,?)");
my $stmiqn=$dbh->prepare("INSERT INTO story(id,type,name,param,next) VALUES (?,?,?,0,?)");
my $stmiqp=$dbh->prepare("INSERT INTO story(id,type,name,param,next) VALUES (?,?,'',?,?)");
my $stmiqnp=$dbh->prepare("INSERT INTO story(id,type,name,param,next) VALUES (?,?,?,?,?)");

my $stmupdjmp=$dbh->prepare("UPDATE story SET next= ? WHERE id= ?");

while($line=<I>) {

# Skip blank and comments

next if $line =~ /^ *$/;
next if $line =~ /^#/;

# Get command part and indentation level

$line =~ /^( *)(.*)$/;
my ($tabs,$cmd) = ($1,$2);
my $ntab = (length($tabs)/4)-1;

# Lexer/parser : get instruction and parameters
$instr="";

if ($cmd =~ /^label +([^: ]+):/) {
    $instr = "lbl";
    $p1=$1;
}

if ($cmd =~ /^jump_out +([^: ]+)/) {
    $instr = "jmp";
    $p1=$1;
}

if ($cmd =~ /^call +iscene *\("([^"]+)"\)/) {
    $instr = "scn";
    $p1=$1;
}

if ($cmd =~ /^call +imenu *\("([^"]+)"\)/) {
    $instr = "menu";
    $p1=$1;
}

if ($cmd =~ /^\$ +([a-zA-Z0-9_]+) *\+= *([0-9]+)/) {
    $instr = "add";
    ($p1,$p2) = ($1,$2);
}

if ($cmd =~ /^if +_return *== *m([0-9]) *:/) {
    $instr = "ifret";
    $p1=$1;
}

if ($cmd =~ /^elif +_return *== *m([0-9]) *:/) {
    $instr = "elifret";
    $p1=$1;
}

if ($cmd =~ /^else:$/) {
    $instr = "else";
}

if ($cmd =~ /^if +seen_scene *\( *"([a-zA-Z0-9_]+)" *\) *:/) {
    $instr = "ifseen";
    $p1=$1;
}

if ($cmd =~ /^if +not +seen_scene *\( *"([a-zA-Z0-9_]+)" *\) *:/) {
    $instr = "ifunseen";
    $p1=$1;
}

if ($cmd =~ /^elif +seen_scene *\( *"([a-zA-Z0-9_]+)" *\) *:/) {
    $instr = "elifseen";
    $p1=$1;
}

if ($cmd =~ /^if +([a-zA-Z0-9_]+) *> *([0-9]+) *:/) {
    $instr = "ifgt";
    ($p1,$p2)=($1,$2);
}

if ($cmd =~ /^elif +([a-zA-Z0-9_]+) *> *([0-9]+) *:/) {
    $instr = "elifgt";
    ($p1,$p2)=($1,$2);
}

if ($cmd =~ /^if +([a-zA-Z0-9_]+) *> *([0-9]+) +and +([a-zA-Z0-9_]+) *> *([0-9]+) *:/) {
    $instr = "ifgtgt";
    ($p1,$p2,$p3,$p4)=($1,$2,$3,$4);
}

if ($cmd =~ /^if +seen_scene *\( *"([a-zA-Z0-9_]+)" *\) +or +seen_scene *\( *"([a-zA-Z0-9_]+)" *\) *:/) {
    $instr = "ifseenor";
    ($p1,$p2)=($1,$2);
}

if ($cmd =~ /^elif +seen_scene *\( *"([a-zA-Z0-9_]+)" *\) +or +seen_scene *\( *"([a-zA-Z0-9_]+)" *\) *:/) {
    $instr = "elifseenor";
    ($p1,$p2)=($1,$2);
}

if ($cmd =~ /^\$ +tcard *\( *([0-9]+) *, *.*\)/ ) {
    $instr = "act";
    $p1 = $1;
}

if ($instr eq "") {
    print "Syntax error : $cmd\n";
    next;
}

# Compiler : compile in bytecode in DB

# First detect different tab number. Need to exclude tab=-1 for labels
if ($ntab > -1) { 
    if ($ntab < $iflvl) {
# if several levels dropped, process inner levels first
	while ($ntab < $iflvl - 1) {
	    $stmi->execute($pc,0); #NOP
	    if ($ifout[$iflvl]) {
		$stmupdjmp->execute($pc,$ifout[$iflvl]);
	    }
	    if ($ifalt[$iflvl]) {
		$stmupdjmp->execute($pc,$ifalt[$iflvl]);
	    }
	    $pc++;
	    $iflvl--;
    }
    if ($instr =~ /^el(se|if)/) {
# JMP getting out of if chained on this JMP
	if ($ifout[$iflvl]) {
	    $stmupdjmp->execute($pc,$ifout[$iflvl]);
	}

	$stmi->execute($pc,1); #JMP
	$ifout[$iflvl]=$pc;
	$pc++;
# Alternative after the JMP
	if ($ifalt[$iflvl]) {
	    $stmupdjmp->execute($pc,$ifalt[$iflvl]);
	    $ifalt[$iflvl]=0;
	}
# else so unconditionnal alternative, no more alternative after
	if ($instr eq "else") {
	    $stmi->execute($pc++,0); #NOP
	} else {
# elif... need to compile condition and set for alternative
	    if ($instr eq "elifret") {
		$stmiqp->execute($pc,4,$p1,$pc+2); #IFRET
		$pc++;
		$ifalt[$iflvl]=$pc;
		$stmi->execute($pc++,1); #JMP
		next;
	    }

	    if ($instr eq "elifseen") {
		$stmiqn->execute($pc,5,$p1,$pc+2); #IFSEEN
		$pc++;
		$ifalt[$iflvl]=$pc;
		$stmi->execute($pc++,1); #JMP
		next;
	    }

	    if ($instr eq "elifgt") {
		$stmiqnp->execute($pc,6,$p1,$p2,$pc+2); #IFGT
		$pc++;
		$ifalt[$iflvl]=$pc;
		$stmi->execute($pc++,1); #JMP
		next;
	    }

	    if ($instr eq "elifseenor") {
		$stmiqn->execute($pc,5,$p1,$pc+3); #IFSEEN
		$pc++;
		$stmiqn->execute($pc,5,$p2,$pc+2); #IFSEEN
		$pc++;
		$ifalt[$iflvl]=$pc;
		$stmi->execute($pc++,1); #JMP
		next;
	    }
	}
    } else {
# Not an ELSE/ELIF
	$stmi->execute($pc,0); #NOP
	if ($ifout[$iflvl]) {
	    $stmupdjmp->execute($pc,$ifout[$iflvl]);
	}
	if ($ifalt[$iflvl]) {
	    $stmupdjmp->execute($pc,$ifalt[$iflvl]);
	}
	$iflvl--;
	$pc++;
    }
  }
# Change of if-scope done
}
# if else or elif, already done, skip
if ($instr =~ /^el(se|if)/) { 
    next;
}
# compile other instructions

if ($instr eq "nop") {
    $stmi->execute($pc++,0); # NOP
    next;
}

if ($instr eq "scn") {
    $stmin->execute($pc++,2,$p1); # SCENE
    next;
}

if ($instr eq "menu") {
    $stmin->execute($pc++,3,$p1); # MENU
    next;
}

if ($instr eq "add") {
    $stminp->execute($pc++,7,$p1,$p2); # VAR+=
    next;
}

if ($instr eq "act") {
    $stmip->execute($pc++,8,$p1); # ACT
    next;
}

# Label : there is no links backwards so no need to keep label/pc assoc
if ($instr eq "lbl") {
    if (defined($labels{$p1})) {
        foreach (@{$labels{$p1}}) {
	    $stmupdjmp->execute($pc,$_);
	}
    }
    next;
}

if ($instr eq "jmp") {
    if ($p1 =~ /(emi|rin|lilly|hanako|bad|shizune)end/) {
	$stmin->execute($pc++,9,$p1);
	next;
    }

    if (!defined($labels{$p1})) {
	$labels{$p1} = [$pc];
    } else {
	push @{$labels{$p1}} , $pc;
    }
    $stmi->execute($pc++,1); #JMP
    next;
}

if ($instr eq "ifret") {
    $stmiqp->execute($pc,4,$p1,$pc+2); #IFRET
    $pc++;
    $iflvl++;
    $ifalt[$iflvl]=$pc;
    $ifout[$iflvl]=0;
    $stmi->execute($pc++,1); #JMP
    next;
}

if ($instr eq "ifseen") {
    $stmiqn->execute($pc,5,$p1,$pc+2); #IFSEEN
    $pc++;
    $iflvl++;
    $ifalt[$iflvl]=$pc;
    $ifout[$iflvl]=0;
    $stmi->execute($pc++,1); #JMP
    next;
}

if ($instr eq "ifunseen") {
    $stmin->execute($pc,5,$p1); #IFSEEN
    $iflvl++;
    $ifalt[$iflvl]=$pc;
    $ifout[$iflvl]=0;
    $pc++;
    next;
}

if ($instr eq "ifgt") {
    $stmiqnp->execute($pc,6,$p1,$p2,$pc+2); #IFGT
    $pc++;
    $iflvl++;
    $ifalt[$iflvl]=$pc;
    $ifout[$iflvl]=0;
    $stmi->execute($pc++,1); #JMP
    next;
}

if ($instr eq "ifgtgt") {
    $stmiqnp->execute($pc,6,$p1,$p2,$pc+2); #IFGT
    $pc++;
    $iflvl++;
    $stmiq->execute($pc,1,$pc+2); #JMP
    $pc++;
    $stmiqnp->execute($pc,6,$p3,$p4,$pc+2); #IFGT
    $pc++;
    $ifalt[$iflvl]=$pc;
    $ifout[$iflvl]=0;
    $stmi->execute($pc++,1); #JMP
    next;
}

if ($instr eq "ifseenor") {
    $stmiqn->execute($pc,5,$p1,$pc+3); #IFSEEN
    $pc++;
    $stmiqn->execute($pc,5,$p2,$pc+2); #IFSEEN
    $pc++;
    $iflvl++;
    $ifalt[$iflvl]=$pc;
    $ifout[$iflvl]=0;
    $stmi->execute($pc++,1); #JMP
    next;
}

# If we reach here, something is broken

print "Invalid token $instr at $pc ($cmd)\n";
}

close(I);


print "Process Messages translations\n";
# Process translation file
open(I,"<FR/ui-strings-FR.rpy");

my %xlate;
my $prop,$str;

while($line=<I>) {

# Skip blank and comments

  next if $line =~ /^ *$/;
  next if $line =~ /^#/;
  next if $line !~ /displayDict\["fr"\]\.(.+) = u?"([^"]*)"/; # "
  ($prop,$str)=($1,$2);

  if ($prop =~ /name_(.*)/) {
    $xlat{$1}=$str;
    next;
  }
}

close(I);

print "Extracting characters info\n";
# Parse UI_Settings for character data

$dbh->do("DROP TABLE character");
$dbh->do("CREATE TABLE character (cid INTEGER PRIMARY KEY AUTOINCREMENT, code TEXT, name TEXT, color TEXT)");

open(I,"<ui_settings.rpy");
my %sound;
my $code,$name,$color;
my %color;
my %colorcode;
my %characters;
my %charname;
my @row;

my $stm=$dbh->prepare("INSERT INTO character(code,name,color) VALUES (?,?,?)");
my $stm2=$dbh->prepare("SELECT cid FROM character WHERE code= ?");

addchar("","");
addchar("n","");
addchar("mystery","???");
addchar("Iwanako","Iwanako");
addchar("Docteur","Docteur");
addchar("Papa","Papa");
addchar("centered","");
addchar("Shiraki","Shiraki");
addchar("Étudiant","Étudiant");
addchar("Teneur du Stand","Teneur du Stand");
addchar("mi_not_shi","<span style=\"text-decoration: line-through\">Shizune</span> Misha");
$dbh->do("UPDATE character SET color='#FF809F' WHERE code='mi_not_shi'");


while($line=<I>) {
    if ($line =~ /store\.(.*) = Character\(displayStrings.name_([^,]*), (.*)\)/ ) {
	($code,$name,$color) = ($1,$2,$3);
	if ($color =~ /kind=([^,]*)/ ) {
	    $color = $color{$1};
	}
	$color =~ /color ?= ?\"(.*)\"/;
	$stm->execute($code,$xlat{$name},$1);
	$color{$code} = $color;
	$colorcode{$code}=$1;
	$charname{$code}=$xlat{$name};
	$stm2->execute($code);
	@row=$stm2->fetchrow_array;
	$characters{$code}=$row[0];
    }
}

close(I);

# Now process scene files

my @files = ("monday","tuesday","wednesday","thursday","friday","saturday","sunday");

my $file;

$dbh->do("DROP TABLE seqtag");
$dbh->do("DROP TABLE seqtext");
$dbh->do("DROP TABLE menu");
$dbh->do("CREATE TABLE seqtag (seqid INTEGER PRIMARY KEY AUTOINCREMENT, tag TEXT, type INTEGER)");
$dbh->do("CREATE TABLE seqtext (seqid INTEGER, seqserial INTEGER, type INTEGER, data TEXT, elid INTEGER, pos INTEGER, z INTEGER)");
$dbh->do("CREATE TABLE menu (seqid INTEGER, qtext TEXT, qid INTEGER, opt1 TEXT, opt2 TEXT, opt3 TEXT, opt4 TEXT)");

$stmaddtag=$dbh->prepare("INSERT INTO seqtag (tag,type) VALUES(?,?)");
$stmqtag=$dbh->prepare("SELECT seqid FROM seqtag WHERE tag=?");
$stmaddtext=$dbh->prepare("INSERT INTO seqtext(seqid,seqserial,type,data,elid,pos,z) VALUES (?,?,?,?,?,?,?)");
$stmaddmenu=$dbh->prepare("INSERT INTO menu(seqid,qtext,qid,opt1,opt2,opt3,opt4) VALUES(?,?,?,?,?,?,?)");
$stmqimg=$dbh->prepare("SELECT iid FROM image WHERE name=?");


foreach $file (@files) {

print "Processing script : $file\n";
open(I,"<FR/script-a1-$file-FR.rpy\n");

my $seqid;
my $seqserial;
my $mode; # 0 = menu, 1 = text
my $cmd;
my $param;
my @menuopt=();
my $menuq="";
my $menuid=0;
my $tag;
my $imgname;
my $z;
my $xpos;
my %xpos=(twoleft => 240, tworight => 560,
	  left => 150, right => 650,
	  closeleft => 200, closeright => 600, 
	  twoleftoff => 256, tworightoff => 544, 
	  centeroff => 416, bgleft => 320, bgright => 480, 
	  offscreenright => 1200, offscreenleft => -400);


$seqid=0;
$seqserial=1;
$mode=1;

while (<I>) {
    chomp;
    next if /^return/;
    next if /^[ \n]*$/;
    next if /^ *with/;
    next if /^window/;
    next if /^play/;
    next if /^#/;
    next if /^stop/;
    next if /^nvl/;
    next if /^menu:/;

# Split in two parts

    /^ *([^ ]+) +(.+)$/;
   
    $cmd=$1;
    $param=$2;    

    if ($cmd eq "label") {
	if ($menuq ne "") {
	    push @menuopt,"";
	    push @menuopt,"";
	    my ($opt1,$opt2,$opt3,$opt4)=@menuopt;

	    $stmaddmenu->execute($seqid,$menuq,$menuid,$opt1,$opt2,$opt3,$opt4);

	    $menuq="";
	    $menuid=0;
	    @menuopt=();
	}

	$param =~ /fr_(choice)?(.*):/;
	if ($1 eq "") {
	    $stmaddtag->execute($2,1);
	    $stmqtag->execute($2);
	    @row=$stmqtag->fetchrow_array;
	    $seqid=$row[0];
	    $mode=1;
	    $seqserial=1;

	} else {
	    $tag="choice$2";
	    $stmaddtag->execute($tag,0);
	    $stmqtag->execute($tag);
	    @row=$stmqtag->fetchrow_array;
	    $seqid=$row[0];
	    $mode=0;
	}
	next;
    }
    
    if ($mode) {
	
# Description text, only item with only 1 item
	if (/^"([^"]+)"( +with.*)?$/) { # "
	    $stmaddtext->execute($seqid,$seqserial,1,$1,1,0,0);
	    $seqserial++;
	    next;
	}

# Character_prefix "text"    
	if (defined($characters{$cmd})) {
	    $param =~ /"([^"]+)"/;
	    $stmaddtext->execute($seqid,$seqserial,1,$1,$characters{$cmd},0,0);
	    $seqserial++;
	    next;
	}

# "name" "text"
	if (/^"/) {
	    /^"([^"]*)" +"(.*)"$/;     #"
	    if (defined($characters{$1})) {
		$stmaddtext->execute($seqid,$seqserial,1,$2,$characters{$1},0,0);
		$seqserial++;
		next;
	    } else {
		print "NAME NOT FOUND : $1\n";
		next;
	    }
	}

# Scene command : change background
	if ($cmd eq "scene") {
	    $param =~ /^(bg|ev)? *(.*?)( *at .*)?$/;
	    if ($1) {
		$imgname="$1_$2.png";
	    } else {
		$imgname="$2.png";
	    }
	    $imgname =~ s/ /_/g;
	    $stmqimg->execute($imgname);
	    @row=$stmqimg->fetchrow_array;
	    if (@row) {
		$stmaddtext->execute($seqid,$seqserial,2,"",$row[0],0,0);
		$seqserial++;
	    } else {
		print "SCENE : IMAGE NOT FOUND $imgname\n";
	    }
	    next;
	}

# Show command
	if ($cmd eq "show") {
	    $param =~ s/(behind +[^ ]+) +(at +[^ ]+)/\2 \1/;
	    $param =~ /^ *(.*?)( at +(.+?))?( behind +[^ ]+)? *$/;
	    $param = $1;
	    $z=10;
	    if ($4) {
		$z=5;
	    }

	    $xpos=400;
	    if ($2) {
		my $posmode=$3;
		if (defined $xpos{$posmode}) {
		    $xpos=$xpos{$posmode};
		} else {
		    if ($posmode =~ /(Zoom|Pan|RotoZoom|Slide|Move|Alpha)/) {
			$xpos=400; # Dummy instruction, not doing anything
		    } else {
			if ($posmode =~ /Position/) {
			    $posmode =~ /xpos=([0-9.]+)/;
			    if ($1) {
				$xpos=800*$1;
			    } else {
				$posmode =~ /xanchor=([0-9.]+)/;
				if ($1) {
				    $xpos=800*$1+150*(0.5-$1);
				} 
			    }
			} else {
			    print "SHOW at $posmode, unknown position\n";
			}
		    }
		}
	    }

	    $param =~ /^ *([^ ]*) *(.*)$/;
	    if ($2) {
		$imgname="$1_$2.png";
		$tag=$1;
	    } else {
		$imgname="$1.png";
		$tag="";
	    }
	    $imgname =~ s/ /_/g;
	    $stmqimg->execute($imgname);
	    @row=$stmqimg->fetchrow_array;
	    if (@row) {
		$stmaddtext->execute($seqid,$seqserial,3,$tag,$row[0],$xpos,$z);
	    } else {
		print "SHOW ERROR : $imgname not found\n";
	    }
	    next;
	}

# Hide command
	if ($cmd eq "hide") {
	    $param =~ s/ *$//;
	    $param =~ s/^ *//;
	    $param =~ s/ /_/g;
	    $stmaddtext->execute($seqid,$seqserial,4,$param,0,0,0);
	    $seqserial++;
	    next;
	}

	if ($cmd eq "\$") {
	    if ($param =~ /written_note ?\(("[^"]+")\)/) { # "
		$stmaddtext->execute($seqid,$seqserial,5,$1,0,0,0);
		$seqserial++;
		next;
	    }
	    if ($param =~/doublespeak ?\(([^)]+)\)/) {
		my @dbl=split /,/,$1;
		
		if (!defined($dbl[3])) {
		    $dbl[3]=$dbl[2];
		}
		$dbl[1] =~ s/ //g;
		$dbl[2] =~ s/ *"(.*)"/\1/g;  # "
		$dbl[3] =~ s/ *"(.*)"/\1/g;  # "
		my $dblstr;
		$dblstr  = "<span style=\"color: " . $colorcode{$dbl[0]} . "\">";
		$dblstr .= $charname{$dbl[0]} . "<br>" . $dbl[2] . "</span>";
		$dblstr .= "<span style=\"color: " . $colorcode{$dbl[1]} . "\">";
		$dblstr .= $charname{$dbl[1]} . "<br>" . $dbl[3] . "</span>";
		$stmaddtext->execute($seqid,$seqserial,6,$dblstr,0,0,0);
		$seqserial++;
		next;
	    }
	    if ($param =~ /renpy_music/) {
		next;
	    }
	    if ($param =~ /_wdt_off/) {
		next;
	    }
	}
	print "$cmd -- $param\n";
    } else {
	if ($menuq eq "") {
	    if (/^ *"([^"]+)"$/) { # "
		$menuq=$1;
		$menuid=1;
		next;
	    } else {
		if (defined($characters{$cmd})) {
		    $param =~ /"([^"]+)"/;
		    $menuq=$1;
		    $menuid=$character{$cmd};
		    next;
		}
	    }
	    next;
	} else {
	    if ( /^ *"([^"]+)":$/) {
		push @menuopt,$1;
		next;
	    } else {
		if ( /^ *return +[a-zA-Z0-9]+$/) {
		    next;
		}
	    }
	}
    }

    if ($menuq ne "") {
	push @menuopt,"";
	push @menuopt,"";
	my ($opt1,$opt2,$opt3,$opt4)=@menuopt;

	$stmaddmenu->execute($seqid,$menuq,$menuid,$opt1,$opt2,$opt3,$opt4);

	$menuq="";
	$menuid=0;
	@menuopt=();
    }
}

}


sub addchar {
    my $stm=$dbh->prepare("INSERT INTO character(code,name,color) VALUES (?,?,?)");
    my $stm2=$dbh->prepare("SELECT cid FROM character WHERE code= ?");
    my ($code,$name)=@_;
    $stm->execute($code,$name,"#FFFFFF");
    $stm2->execute($code);
    my @row=$stm2->fetchrow_array;
    my $cid=$row[0];
    $characters{$code}=$cid if ($code);
}