use strict; use warnings; use JSON; use File::Find qw(finddepth); use Encode qw(decode); #### START OF GLOBAL VARS my $fh; # Output file handle my $imgDirectory = 'C:/Users/Owner/My Website/img/covers'; #### END OF GLOBAL VARS #### START OF MAIN PROGRAM #### my $respJsonData = loadJson("responses.json.txt"); my $nworks = keys %{ $respJsonData->{'works'} }; foreach my $commandKey (keys %{$respJsonData->{"commands"}}) { makeResponsePage($commandKey); } makeIndexPage(); #### END OF MAIN PROGRAM #### sub loadJson { my $inname = $_[0]; my $jsondata = ''; open(my $jinfh, "<", $inname) || die("can't open $inname: $!"); print "*** reading $inname ... "; while ( <$jinfh> ) { $jsondata .= $_; } close $jinfh; print "DONE!\n"; print "*** parsing $inname ... "; $jsondata =~ s/^\x{ef}\x{bb}\x{bf}//; # decode_json doesn't like these leading bytes, the "Byte Order Mark" aka BOM. my $hashref = decode_json $jsondata; print "DONE!\n"; return $hashref; } sub makeIndexPage { open($fh, ">:encoding(UTF-8)", "index.html"); print $fh "\n\n\n"; print $fh "\n"; print $fh "\n"; print $fh "IF Responses\n"; print $fh "\n\n"; print $fh "\n

\"\" IF Responses

\n\n"; print $fh "

Datamining $nworks works of interactive fiction:

\n"; print $fh "\n\n"; print $fh "

Other versions of these pages will be kept around until all their data has been absorbed into the new versions:

\n"; print $fh "\n\n"; print $fh "

About this Responser project

\n"; print $fh "

I don't expect to stay around forever, so I'm also publishing the raw data and program that I used to create these pages."; print $fh " If you wish to continue (update, modify, expand) this project or make a similar project and not want to start from scratch, please feel free to use my materials."; print $fh " Crediting me would be nice, please and thank you."; print $fh " In the meantime, I retain the right to maintain my own version of this project as long as I'm willing and able to do it.

\n"; print $fh "\n"; print $fh "

Note that prior to the creation of the Responser program in January 2018, all the response pages were marked up manually in Notepad.

\n"; print $fh "

And last but not least, a HUGE thank you to all you authors of interactive fiction. You are all amazing. Thank you.

\n"; print $fh "

— David Welbourn

\n"; doFooter('index'); print $fh "\n\n"; close $fh; } sub makeResponsePage { my $commandKey = $_[0]; my $respFilename = $commandKey . ".html"; open($fh, ">:encoding(UTF-8)", $respFilename); print $fh "\n\n\n"; print $fh "\n"; print $fh "\n"; print $fh "" . uc($commandKey) . " Responses\n"; print $fh "\n"; insertJS(); print $fh "\n\n"; print $fh "\n

\"\"" . uc($commandKey) . " Responses"; print $fh ""; print $fh "\"[top]\""; print $fh " \"[menu]\""; print $fh "

\n\n"; print $fh "
\n\n"; print_vmenu(); # The vertical menu with the sort menuitems. my $v = $respJsonData->{'commands'}->{$commandKey}; # Intro if (exists($v->{'intro'})) { my $s = $v->{'intro'}; print $fh "

" if (substr($s,0,1) ne '<'); print $fh $s; print $fh "

" if (substr($s,0,1) ne '<'); print $fh "\n
\n"; } # Temporary buttons # print $fh "\n

"; # print $fh " "; # print $fh " "; # print $fh " "; # print $fh ""; # print $fh "

\n\n"; # Main: Gather info my @rawInfo = (); foreach my $k (keys %{$respJsonData->{'works'}}) { my $v = $respJsonData->{'works'}{$k}; if (exists($v->{$commandKey})) { # Process normal response: my $resp = $v->{$commandKey}; if ($resp !~ /^!!/ and $resp ne '-') { my $relyear = calcReleaseYear($k, $v); my $revyear = 9999 - $relyear; my $r = { 'id' => $k, 'title' => $v->{'title'}, 'grp' => '1', 's1' => '1 ' . title2sort($v->{'title'}), 's2' => '1 ' . resp2sort($resp), 's3' => '1 ' . $relyear . ' ' . title2sort($v->{'title'}), 's4' => '1 ' . $revyear . ' ' . title2sort($v->{'title'}), 'resp' => $resp }; if (exists($v->{'sfx'})) { $r->{'sfx'} = $v->{'sfx'}; } $r->{'year'} = $relyear; if (exists($v->{$commandKey . '_nb'})) { $r->{'nb'} = $v->{$commandKey . '_nb'}; } # Either push the record or merge it with an existing record: insertRecordIntoRaws( $r, \@rawInfo ); } else { # Process special response: my ($grp, $h2, $id, $title); if ($resp =~ /^(\-|!! >notunderstood)$/) { $h2 = 'notunderstood'; $grp = '5'; $id = 'see_notunderstood'; $title = uc($commandKey) . ' is not understood'; } elsif ($resp =~ /^!! >(.*)$/) { $h2 = $1; $grp = '2'; $id = 'see_' . $h2; $title = uc($commandKey) . ' acts like ' . uc($h2); } elsif ($resp =~ /^!! \~(.*)$/) { $h2 = $1; $grp = '2'; $id = 'sim_' . $h2; $title = uc($commandKey) . ' acts like ' . uc($h2) . ' (but substitutes ' . uc($commandKey) . ' for ' . uc($h2) . ' in the response)'; } elsif ($resp =~ /^!! @(.*)$/) { $h2 = $1; $grp = '3'; $id = 'default_' . s2id($h2); $title = uc($commandKey) . ' default in ' . $h2; } elsif ($resp =~ /^!! n\/a$/) { $h2 = 'n/a'; $grp = '6'; $id = 'n_a'; $title = uc($commandKey) . ' is not applicable'; } # Find or create the record. my ($r) = grep {$_->{'id'} eq $id} @rawInfo; if (!defined($r)) { $r = { 'id' => $id, 'title' => $title, 'grp' => $grp, 's1' => $grp . ' ' . lc($h2), 's2' => $grp . ' ' . lc($h2), 's3' => $grp . ' ' . lc($h2), 's4' => $grp . ' ' . lc($h2) }; } # Add default system response and its nb, if applicable. if ($grp eq '3' and exists($respJsonData->{'systems'}{$h2})) { my $sysrec = $respJsonData->{'systems'}{$h2}; if (exists($sysrec->{$commandKey})) { $r->{'resp'} = $sysrec->{$commandKey}; $r->{'s2'} = '1 ' . resp2sort($r->{'resp'}); } if (exists($sysrec->{$commandKey . '_nb'})) { my $nb = $sysrec->{$commandKey . '_nb'}; if ($nb !~ /^' . $nb . '

'; } $r->{'nb'} = $nb; } } # Add work title to titles my $worktitle = $v->{'title'}; $worktitle .= ' (' . $v->{'sfx'} . ')' if defined($v->{'sfx'}); if (exists($r->{'titles'})) { push @{$r->{'titles'}}, $worktitle; } else { $r->{'titles'} = [ $worktitle ]; } # Add work's resp_nb, if any. if (exists($v->{$commandKey . '_nb'})) { my $nb = $v->{$commandKey . '_nb'}; if ($nb !~ /^' . $nb . '

'; } if (exists($r->{'nb'})) { $r->{'nb'} .= $nb; } else { $r->{'nb'} = $nb; } } push @rawInfo, $r unless grep {$_->{'id'} eq $id} @rawInfo; } } } # Sorting my @sortedInfo = sort { $a->{'s2'} cmp $b->{'s2'} } @rawInfo; my $counter = 1000; foreach my $r (@sortedInfo) { $r->{'s2'} = $counter++; # Replace s2 field with a 4-digit number to sort by. } @sortedInfo = sort { $a->{'s3'} cmp $b->{'s3'} } @sortedInfo; $counter = 1000; foreach my $r (@sortedInfo) { $r->{'s3'} = $counter++; # Replace s3 field with a 4-digit number to sort by. } @sortedInfo = sort { $a->{'s4'} cmp $b->{'s4'} } @sortedInfo; $counter = 1000; foreach my $r (@sortedInfo) { $r->{'s4'} = $counter++; # Replace s4 field with a 4-digit number to sort by. } @sortedInfo = sort { $a->{'s1'} cmp $b->{'s1'} } @sortedInfo; $counter = 1000; foreach my $r (@sortedInfo) { $r->{'s1'} = $counter++; # Replace s1 field with a 4-digit number to sort by. } # Main: Output my $nresp = 0; print $fh "\n\n"; # End of respList. # Remember the number of responses. $respJsonData->{'commands'}{$commandKey}{'nresp'} = $nresp; # Outro print $fh "
\n"; if (exists($v->{'outro'})) { my $s = $v->{'outro'}; print $fh "

" if (substr($s,0,1) ne '<'); print $fh $s; print $fh "

" if (substr($s,0,1) ne '<'); print $fh "\n"; } print $fh "

Do you want to see the "; my @otherCommands = (); foreach my $command (sort keys %{$respJsonData->{"commands"}}) { push @otherCommands, $command if $command ne $commandKey; } my $n = 1; my $nCommands = scalar(@otherCommands); foreach my $command (@otherCommands) { print $fh "or " if $n == $nCommands; print $fh "". uc($command) . ""; print $fh "," if $n != $nCommands; print $fh " "; $n++; } print $fh " page next?

"; doFooter($commandKey); print $fh "\n\n"; close $fh; } sub doFooter { my $commandKey = $_[0]; my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); my $dd = substr('0' . $mday,-2); my $mmm = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec')[$mon]; my $yyyy = 1900 + $year; print $fh "\n"; } sub print_vmenu { my $code = <<'END_VMENU'; END_VMENU print $fh $code; } sub title2sort { my $s = $_[0]; $s = lc($s); if ($s =~ /^(.*)\|(.*)$/) { $s = $2 . ' (' . $1 .')'; } # TODO: replace accented characters with unaccented ones. return $s; } sub title2html { my $s = $_[0]; $s =~ s/\|//g; $s =~ s/&/&/g; $s =~ s//>/g; $s =~ s/\[or\]/|/g; return $s; } sub s2id { my $s = $_[0]; $s = lc($s); $s =~ s/ /_/g; $s =~ s/\//_/g; return $s; } sub calcReleaseYear { my ($k, $v) = @_; if (exists($v->{'year'})) { return $v->{'year'}; } else { my $yy = substr($k, 5, 2); # scrape the 2-digit year from the id. if ($yy eq 'xx' || $yy eq '') { return '0000'; } elsif ($yy ge '70') { return '19' . $yy; } else { return '20' . $yy; } } } sub insertJS { my $jsCode = <<'END_JSCODE'; END_JSCODE print $fh $jsCode; } # Convert a response string into something I can sort by. sub resp2sort { my $s = $_[0]; $s = lc($s); $s =~ s/\n/ /gs; # $s =~ s/\[.*?\]<\/i>//g; # remove my embedded comments. (old markup!) $s =~ s/.*?<\/ins>//g; # remove my embedded comments. (new markup!) $s =~ s/<.*?>//g; # remove all HTML tags. $s =~ s/&[a-z]+;/ /g; # remove   etc. # TODO: remove accents on characters. $s =~ s/\s+/ /g; # replace whitespace sequences with single space. $s =~ s/^[^a-z0-9]+//; # remove leading non-alphanumerics. if (length($s) > 50) { # chop down to 50 characters if longer. $s = substr($s,0,50); } return $s; } sub insertRecordIntoRaws { my ($r1, $raws) = @_; # Find out if there's already a record with the new record's response. my ($r2) = grep {$_->{'grp'} eq '1' and $_->{'resp'} eq $r1->{'resp'}} @{$raws}; if (!defined($r2)) { # It's a new response. Add the new record and we're done! push @{$raws}, $r1; return; } # Ugh. We now want to merge $r1 into $r2. # So we now need to figure out which work is older, more or less. # Use the third sort field (Sort by Year) for this. if ($r1->{'s3'} lt $r2->{'s3'}) { # Case 1: $r1 is older. # First, add $r2's title to $r2's titles array. my $r2Title = $r2->{'title'}; $r2Title .= ' (' . $r2->{'sfx'} . ')' if defined($r2->{'sfx'}); if (exists($r2->{'titles'})) { push @{$r2->{'titles'}}, $r2Title; } else { $r2->{'titles'} = [ $r2Title ]; } # Second, subplant $r2's other fields with $r1's. $r2->{'id'} = $r1->{'id'}; $r2->{'title'} = $r1->{'title'}; $r2->{'s1'} = $r1->{'s1'}; $r2->{'s2'} = $r1->{'s2'}; $r2->{'s3'} = $r1->{'s3'}; $r2->{'s4'} = $r1->{'s4'}; if (defined($r1->{'sfx'})) { $r2->{'sfx'} = $r1->{'sfx'}; } elsif (defined($r2->{'sfx'})) { undef $r2->{'sfx'}; } if (exists($r1->{'year'})) { $r2->{'year'} = $r1->{'year'}; } elsif (exists($r2->{'year'})) { undef $r2->{'year'}; } if (exists($r1->{'nb'})) { $r2->{'nb'} = $r1->{'nb'}; } elsif (exists($r2->{'nb'})) { undef $r2->{'nb'}; } # Note that we might want to combine nb fields in the future. # Note that the resp field can be left alone since it's the same. # Note that the img field doesn't exist at all yet; that's later. } else { # Case 2: $r2 is older. # So just add $r1's title to $r2's titles array. my $r1Title = $r1->{'title'}; $r1Title .= ' (' . $r1->{'sfx'} . ')' if defined($r1->{'sfx'}); if (exists($r2->{'titles'})) { push @{$r2->{'titles'}}, $r1Title; } else { $r2->{'titles'} = [ $r1Title ]; } } } #### NOTES #### # # Regarding $grp in the "special response" processing, its value is one of: # '1' means a work has its own response for this VERB. # '2' means a "VERB acts like VERB2" group. # '3' means a "VERB default in System" group. # '4' means a "VERB is handled oddly" group. # '5' means a "VERB is not understood" group. # '6' means a "VERB is not applicable" group. # The values are the way they are just so I can sort the groups in this order.