#!/usr/local/bin/perl ################################################################################# # MK_ROOM_NAME # # (c) 1999 by Toni Arnold, Zurich # ------------------------------------------------------------------------------ # Perl-Script that creates automatically room names for goto.h # If you don't use goto.h this script is totally useless for you # # Version 1.0 # Serial Number 990620 # # Some information about perl can be found at: # http://www.gnu.org/software/perl/perl.html # ------------------------------------------------------------------------------ # Comments and bug reports to: # tarnold@cl.unizh.ch # # Copying is free as long as it is # - not commercial # - copied as a whole # ------------------------------------------------------------------------------ # # Description # ----------- # The script searches all room objects for their directions attached. # For every room it extracts each word of its short_name and writes # it separately into the name-array of the room_name. # The room_name-objects are floating objets seen everywhere wich are # used by the go to verb. # If you use that script you don't have to write these objects by yourself. # # Rooms which cannot be identified by their name are put out as one single # room which is commented out with # ! ######## name "schilfrohr" not unique ########, # If you like to mark one of these ambiguous rooms as the target room # (in the example the "schilfrohr"-object of more than one object) # add at the end (!) of the object definition line the comment ! #goto # e.g.: AboveGround In_Forest_1 "In Forest" ! #goto # # ------------------------------------------------------------------------------ # Call # ---- # # perl informap.pl infile [outfile] [flags] # # inflie # ------ # The main inform file. Include-Paths are followed (see below). # # outfile # ------- # The default filename is [inflie].room_name.inform # # Some machines (eg. DOS) don't allow long filenames. For that reason # the second argument is recognized as the output filename if it is # not a flag. If there are multiple columns selected, the (necessary) # numbers in the filename are added as extension to the outfile which # makes it a file type. This not really good, but I found no other # general solution. # # Flags # ----- # # flags are recognized by a letter followed by = # ignores the case of the flag letter and they can appear in any order # # f=[on/off] e.g. f=off # ---------- # This flag indicates whether "Include"-FILEPATHS should be FOLLOWED # or not. There are files defined which are ignored always. Edit # @include_ignore = (...); below to add files to the ignore-list. # Default is on. # # c=[on/off] e.g. c=on # ---------- # If this flag is set the script really works: it copies # all the source code containing room descriptions to # source.goto in the same directories and adjusts the # include statements in the main file, too. # To build a game compile the file source.goto # Default is off. # # d=[on/off] e.g. d=on # ---------- # If this flag is set the script makes a dictionary of the rooms # in the order they appeared. If you want the order # alphabetivally then sort it with your ASCII-editor. # Default is off. # # l=[language] e.g. N=deutsch # ------------ # # This is for my german translation and creates additionally # an (null) declination property. # range: [english/deutsch] # Defaults to english. # # # Comment about the call in Windows # --------------------------------- # On Unix it is possible to call perl without "perl" by adjoining the # perl binary path to the first line of the script. On Windows NT *.pl # can be associated with perl, which works at least with the ActiveState # distribution. # ------------------------------------------------------------------------------ # # Revision history # ---------------- # # V1.0 first release # # ------------------------------------------------------------------------------ # # Known Bugs and lacks # -------------------- # # - The names of the room have to be given in its object header, the # short_name - property is not looked at. # - Doors (door_dir) are not handled # - in_to/out_to is not handled # - before go-routines are handled here, but not n goto.h! # # ------------------------------------------------------------------------------ # This file contains the whole commented source code. ################################################################################# # This Array contains "include"-files that shoud be ignored. # It can be parts of the game that should not be "mapped" # or - more important - library files containig rooms # Case is ignored! @include_ignore = ("Parser","VerbLib","Grammar", "Infix", "infix.h", "goto.h", "GermanG"); # language library $outfile_suffix = ".room_name"; # change it if you like it different $outfile_type = ".txt"; $copyfile_suffix = ".goto"; ####################### # Print title message # ####################### print "\nMK_ROOM_NAME V1.0b0\n"; print "(c) 1999 by Toni Arnold, Zurich\n\n"; ####################### SECTION 1: GET COMMAND LINE ########################## ##################################### # get the arguments ##################################### # first argument = inform file # $inform to draw a map from # -> open it and read content to # @inform $inform = $ARGV[0]; $outfile_name = $inform; # can be overridden by explicite filename if ((not defined($inform)) or ($inform =~ /\w=.*/)) { die "No input file specified!\nCall: perl informap.pl infile [outfile] [flags]\n"; } # argument defaults $include_flag = "on"; $copy_flag = "off"; $dict_flag = "off"; $language = "english"; # facualtative more arguments # n=13 width of the room Names (default = 11) for ($i=1;$i<=@ARGV;$i++) { # number of arguments if (defined($ARGV[$i])) { $arg = $ARGV[$i]; if (($i==1) && ($arg ne "") && # second argument as possible filename ($arg !~ /\w=.*/)) { # matches everything except flags $outfile_name = $arg; # take it as outfilename $outfile_suffix = ""; # no additional suffix and type $outfile_type = ""; $arg = ""; # mark as done }; if (lc($arg) eq "f=on") { # --- F=ON --- $include_flag = "on"; $arg = ""; }; if (lc($arg) eq "f=off") { # --- F=OFF --- $include_flag = "off"; $arg = ""; }; if (lc($arg) eq "c=on") { # --- C=ON --- $copy_flag = "on"; $arg = ""; }; if (lc($arg) eq "f=off") { # --- C=OFF --- $copy_flag = "off"; $arg = ""; }; if (lc($arg) eq "d=on") { # --- d=ON --- $dict_flag = "on"; $arg = ""; }; if (lc($arg) eq "d=off") { # --- d=OFF --- $dict_flag = "off"; $arg = ""; }; if (lc($arg) eq "l=deutsch") { # --- L=german --- $language = "deutsch"; $arg = ""; }; if (lc($arg) eq "l=english") { # --- L=english --- $language = "english"; $arg = ""; }; if ($arg ne "") { # !! die on invalid arguments !! die ("Invalid argument: $arg\n"); }; }; }; ############################################## # ------------------------------------------- # accommodate_new_room # ------------------------------------------- # The hash array @room[n] contains afterwards # for each room n an entry with its # textual name. # ------------------------------------------- # It is called inside the input line loop # every time when a direction is detected. # if it's the first direction of the object, # then the object is recognized as a room # and stores it in the @rooms-Array # ------ # It is not object oriented and makes use # of global variables. Sorry. ############################################## @room_name = ("name","short_name","new_name","input_name"); sub accommodate_new_room { my($i,$existing_input_name,$existing_room_name,@existing_list,$once); if ($room_detected eq "false") { # if it's not already recogn. as a room if ($room_input_name ne "") { # only for real names unique test $once = 0; # reset $once flag to prevent multiple "&" foreach $existing_room_name (@room_list) { # loop through every existing name $existing_input_name = $room{$existing_room_name.$room_name[3]}; if ($existing_input_name ne "") { # test only against real names if ((($existing_input_name eq $room_input_name) || # if not unique name array! ($existing_input_name eq "& $room_input_name")) # or already marked as not unique && ($once == 0)) { $room_input_name = "& $room_input_name"; # non-alphanumerics dont' occur here, $once = 1; # so this is safe if ($room{$existing_room_name.$room_name[3]} !~ /&.*/) { $room{$existing_room_name.$room_name[3]} = "& $room{$existing_room_name.$room_name[3]}"; # prefix original room wit & too } } } } } $room_number++; # increase room number to new room @room_list[$room_number] = $possible_room; # possible room is now really a room $room{$possible_room.$room_name[1]} = "$room_short_name"; # short_name of the room object $room{$possible_room.$room_name[2]} = "r_n$room_number"; # inform name of the room object $room{$possible_room.$room_name[3]} = "$room_input_name"; # concat. of all name-propertoes $room_file_history{$input_file} = 1; # file is recognized as containing rooms $room_detected = "true"; # mark current room as initialized } } # -------------------------------------------------- # is_valid_file(Filename) # checks the Filename case insensitive against # @include_ignore (at the beginning of the script) # returns true if it is valid, else false # -------------------------------------------------- sub is_valid_filename { my($file) = @_; my($i,$end,$out); $out = "true"; # init default value $end = @include_ignore; for ($i=0;$i<$end;$i++) { # loop trough every skip filename if ($file =~ /.*$include_ignore[$i]\Z/i) { $out = "false"; } } $out; } # ---------------- input line loop -------------------- # @inform holds the current inform file # graps the information from this file # to handle include-statements it is a subroutine $InfClass[0] = "object"; # Initialize; is always of class object sub input_line_loop { my($i,$objclass); $line_number=0; $room_detected = "false"; # whether current object is a room $before_detected = "false"; # for before go: n_obj: PlayerTo... $go_detected = "false"; # the 'go:' itself $go_obj_detected = ""; # no go-obj yet detected while () { $line = $_; # $line contains the actual line if ($line !~ /^\s*!/) { # skip commented lines $line =~ s/!\s*#\s*goto.*\Z/#goto/i; # uncomment the #goto-marker $line =~ s/!.*//; # remove other comments at the end # pattern matching: recognize Include-Statements if (($line =~ /include\s*"(.+)"/i) and (is_valid_filename($1) eq "true")) { if ($include_flag eq "on") { push (@file_stack,$1); } if (($include_flag eq "on") || ($input_file eq $inform)) { $room_file_history{$input_file} = 1; # file is recognized as containing includes } } # pattern matching: recognize new inform classes if ($line =~ /class\s+(\w+)/i) { $InfClass[@InfClass] = lc($1); # add at the end of array }; # repeated pattern matching: recognize object header (= new room) $obj_class = "false"; for ($i=0;$i<@InfClass;$i++) { if ($line =~ /$InfClass[$i]\s+(\w+)(.*)\Z/i) { # ^word "object" or any class # ^word boundary # ^name of the (possible) room object $obj_class = "true"; $possible_room = lc($1); # "room" that matched with object or class # (could be any object up to now) $room_short_name = $2; if ($room_short_name =~ /.*".*".*/) { if ($language ne "english") { if ($language eq "deutsch") { $room_short_name =~ s/ä/\@:a/g; # change foreign ascii chars $room_short_name =~ s/Ä/\@:a/g; $room_short_name =~ s/ö/\@:o/g; $room_short_name =~ s/Ö/\@:o/g; $room_short_name =~ s/ü/\@:u/g; $room_short_name =~ s/Ü/\@:u/g; $room_short_name =~ s/ß/\@ss/g; } } $room_short_name =~ s/^[^"]*//o; # remove anything before name $room_short_name =~ s/[^"]*$//o; # remove anything after name $room_input_name = lc($room_short_name); $room_input_name =~ s/[^\w\s\@:]//g; # only alphanum. and spaces $room_input_name =~ s/\@:a/ae/g; # change foreign ascii chars $room_input_name =~ s/\@:o/oe/g; $room_input_name =~ s/\@:u/ue/g; $room_input_name =~ s/\@ss/ss/g; @name_list = split(/ /,$room_input_name); # create array of words undef %saw; # make words unique @name_list_unique = grep(!$saw{$_}++, @name_list); @name_list_unique = sort(@name_list_unique); $room_input_name = ""; # rebuild input name foreach $element (@name_list_unique) { if ($element ne "") { # never add spaces if ($room_input_name eq "") { $room_input_name = $element; } else { $room_input_name = "$room_input_name $element"; } } } if ($line =~ /#goto$/i) { # the target for ambiguous rooms push(@go_to_rooms,$possible_room); } } else { $room_short_name = ""; # only "names" are reconized $room_input_name = ""; } } } if ($obj_class eq "true") { # recognizes any objects and classes $possible_room =~ s/\Afalse\Z/false /; # avoid name conflicts because # FOR PERL false is equal to the string "false" (SHIT) -> add a space $room_detected = "false"; # so it is not detected as room up to now $before_detected = "false"; # and no before $go_detected = "false"; # and no go up to now $go_obj_detected = ""; # no go-obj yet detected }; # DO NOT recognize short_name (because it would have to happen before # a room is detected as such and it's not really inform style # if ($line =~ /short_name\s*"([^"])"\s"/i) { # $room_short_name = $1; # }; # === pattern matching: assign the explicite directions === if ($line =~ /\bn_to\s+(\w+)/i ) { &accommodate_new_room; }; if ($line =~ /\bne_to\s+(\w+)/i ) { &accommodate_new_room; }; if ($line =~ /\be_to\s+(\w+)/i ) { &accommodate_new_room; }; if ($line =~ /\bse_to\s+(\w+)/i ) { &accommodate_new_room; }; if ($line =~ /\bs_to\s+(\w+)/i ) { &accommodate_new_room; }; if ($line =~ /\bsw_to\s+(\w+)/i ) { &accommodate_new_room; }; if ($line =~ /\bw_to\s+(\w+)/i ) { &accommodate_new_room; }; if ($line =~ /\bnw_to\s+(\w+)/i ) { &accommodate_new_room; }; if ($line =~ /\bu_to\s+(\w+)/i ) { &accommodate_new_room; }; if ($line =~ /\bd_to\s+(\w+)/i ) { &accommodate_new_room; }; if ($line =~ /\bin_to\s+(\w+)/i ) { &accommodate_new_room; }; if ($line =~ /\bout_to\s+(\w+)/i ) { &accommodate_new_room; }; # === pattern matching: assign the before go: - directions === if ($line =~ /\bbefore\b/i ) { # detect before $before_detected = "true"; }; if ($line =~ /\bgo\s*:/i ) { # detect go if ($before_detected eq "true") { # only if before is already detected $go_detected = "true"; }; }; # --- recognize go_objects --- if ($go_detected eq "true") { if ($line =~ /\b(n_obj)\s*:/i ) { $go_obj_detected = lc($1); }; if ($line =~ /\b(ne_obj)\s*:/i ) { $go_obj_detected = lc($1); }; if ($line =~ /\b(e_obj)\s*:/i ) { $go_obj_detected = lc($1); }; if ($line =~ /\b(se_obj)\s*:/i ) { $go_obj_detected = lc($1); }; if ($line =~ /\b(s_obj)\s*:/i ) { $go_obj_detected = lc($1); }; if ($line =~ /\b(sw_obj)\s*:/i ) { $go_obj_detected = lc($1); }; if ($line =~ /\b(w_obj)\s*:/i ) { $go_obj_detected = lc($1); }; if ($line =~ /\b(nw_obj)\s*:/i ) { $go_obj_detected = lc($1); }; if ($line =~ /\b(u_obj)\s*:/i ) { $go_obj_detected = lc($1); }; if ($line =~ /\b(d_obj)\s*:/i ) { $go_obj_detected = lc($1); }; }; # --- beginning of before go - playerto-routines --- if (($go_obj_detected eq "n_obj") && ($line =~ /\bplayerto\((\w+)/i )) { &accommodate_new_room; }; if (($go_obj_detected eq "ne_obj") && ($line =~ /\bplayerto\((\w+)/i )) { &accommodate_new_room; }; if (($go_obj_detected eq "e_obj") && ($line =~ /\bplayerto\((\w+)/i )) { &accommodate_new_room; }; if (($go_obj_detected eq "se_obj") && ($line =~ /\bplayerto\((\w+)/i )) { &accommodate_new_room; }; if (($go_obj_detected eq "s_obj") && ($line =~ /\bplayerto\((\w+)/i )) { &accommodate_new_room; }; if (($go_obj_detected eq "sw_obj") && ($line =~ /\bplayerto\((\w+)/i )) { &accommodate_new_room; }; if (($go_obj_detected eq "w_obj") && ($line =~ /\bplayerto\((\w+)/i )) { &accommodate_new_room; }; if (($go_obj_detected eq "nw_obj") && ($line =~ /\bplayerto\((\w+)/i )) { &accommodate_new_room; }; if (($go_obj_detected eq "u_obj") && ($line =~ /\bplayerto\((\w+)/i )) { &accommodate_new_room; }; if (($go_obj_detected eq "d_obj") && ($line =~ /\bplayerto\((\w+)/i )) { &accommodate_new_room; }; # --- end of before go - directions --- # if ($line =~ /\bdoor_dir\s+(\w+)/i ) { # &accommodate_new_room; # $r = "\L$1\E"; # $r =~ s/\Afalse\Z/false /; # avoid name conflicts # @room[($room_number*$room_elements)+$door_dir] = $r; # }; }; # endif skip commented lines $line_number++; # get next line }; } # ------------ end of input line loop ----------------- ############################################ # Load the Infocom Game File(s) into @inform # $inform holds the main file name ############################################ # STATUS print "Extracting room names out of the file '$inform'\n"; $room_number=-1; # initialize room counter (-1 for no room) $input_file = $inform; # main file = first input file $outfile = "$outfile_name$outfile_suffix$outfile_type"; while (defined($input_file)) { # loop for all include files $skip_nonfile = "false"; # for skipping nonexistent files unless (open(INFORMFILE, $input_file)) { if ($input_file eq $inform) { # unable to open main file if (-e $input_file) { die ("Inform main file '$input_file' exists, but cannot be opened\n"); } else { die ("Can't open Inform main file '$input_file'\n"); }; } else { if (-e $input_file) { print "Included Inform file '$input_file' exists, but cannot be opened\n"; } else { print "Can't open included Inform file '$input_file'\n"; }; $skip_nonfile = "true"; }; }; if ($skip_nonfile eq "false") { # if it could be opened if ($input_file ne $inform) { # message only for include files print "Including '$input_file'\n"; }; &input_line_loop; # get the whole information from the file close(INFORMFILE); # close it }; $input_file = pop(@file_stack); # Include-Statements can push files }; # ----------------------------------- # for debugging: # print the information got from # the inform file # to switch on comment out: # - - - - - - - - - - - - - - - - - - # &print_room_array; # ----------------------------------- sub print_room_array { $t = $room_number + 1; print "\ntotal number of rooms: $t\n\n"; for ($i=0;$i<=$room_number;$i++) { print "Room: $room[$i]\n"; }; print "\n\n"; } # STATUS print "Got map data\n"; ########################### # test wether go_to_rooms # are unique. # die otherwise ########################### undef %saw; undef %memory; foreach $unique_go_room (@go_to_rooms) { $name_of_ugr = $room{$unique_go_room.$room_name[3]}; $name_of_ugr =~ s/^& //o; # remove duplicate marker & $saw{$name_of_ugr}++; if ($saw{$name_of_ugr} >= 2) { die ("\n\n! #goto ERROR: room names '$name_of_ugr' of $unique_go_room equal as of $memory{$name_of_ugr}\n"); } $memory{$name_of_ugr} = $unique_go_room; } ############################ # save room names into file ############################ if ($dict_flag eq "on") { # STATUS print "Saving '$outfile'\n"; # do the save operation unless (open(OUTFILE, ">$outfile")) { die ("Can't write to output file '$outfile'\n"); }; print OUTFILE "! ------------------------------\n"; print OUTFILE "! $inform\n"; print OUTFILE "! Dictionary for\n"; print OUTFILE "! room name objects for goto.h\n"; print OUTFILE "! created by mk_room_name\n"; print OUTFILE "! from Toni Arnold\n"; print OUTFILE "! ------------------------------\n\n\n"; foreach $name (@room_list) { # loop through each room $short_name = $room{$name.$room_name[1]}; $in_name = $room{$name.$room_name[3]}; # cleaned short_name @name_list = split(/ /,$in_name); # list of all name properties of room # --- object header (without ,) --- print OUTFILE "$short_name | $name |"; # --- object name property (with , because of comments) --- if ($in_name ne "") { if ($in_name !~ /&.*/) { # if not marked as not unique foreach $parse_name (@name_list) { if ($parse_name ne "") { print OUTFILE " \"$parse_name\""; } } } else { # if not unique room could be in @go_to_rooms $member = 0; foreach $element (@go_to_rooms) { if ($element eq $name) { $member = 1; } } if ($member == 1) { # if it *is* in @to_to_rooms foreach $parse_name (@name_list) { if (($parse_name ne "") && ($parse_name ne "&")) { print OUTFILE " \"$parse_name\""; } } print OUTFILE " ! ### goto ###"; # COMMA of name-property } else { print OUTFILE " ! ######## name"; # COMMA of name-property foreach $parse_name (@name_list) { if (($parse_name ne "") && ($parse_name ne "&")) { print OUTFILE " \"$parse_name\""; } } print OUTFILE " not unique ########"; } } # end of if not unique } # end of empty in name # -- language specific stuff -- # if ($language ne "english") { # if ($language eq "deutsch") { # print OUTFILE "\n dekl 0, has male"; # } # } print OUTFILE ";\n\n"; } close(OUTFILE); } ################################################################################ # Copy all files contining rooms # to file.goto and add to each room # the goto_steps property # and the name array # ---------------------------- sub copy_inform_file_loop { $obj_to_adjust = 0; # init flag while () { $line = $_; # $line contains the actual line chomp($line); if ($line !~ /^\s*!/) { # skip commented lines # pattern matching: recognize Include-Statements and adjust them with suffix if (($line =~ /include\s*"(.+)"/i) and (is_valid_filename($1) eq "true")) { if ($room_file_history{$1} == 1) { $line =~ s/include\s*"(.+)"/include "$1$copyfile_suffix"/i; } } # room object headers for ($i=0;$i<@InfClass;$i++) { if ($line =~ /$InfClass[$i]\s+(\w+)(.*)\Z/i) { # ^word "object" or any class # ^word boundary # ^name of the (possible) room object print ($1); $possible_room = lc($1); $room_index = $room_list_hash{$possible_room}; if ($room_index >= 1) { # if the obj is in the room list $obj_to_adjust = 2; # flag ist true (with is to be replaced) } else { # but not before the next line $obj_to_adjust = 0; } } } # adjusting lines including with if ($obj_to_adjust >= 1) { if ($obj_to_adjust == 2) { $obj_to_adjust=1; } else { if ($line =~ s/\bwith\b(.*)/with/i) { $line_rest = $1; # remember rest of the line that was cut here $obj_to_adjust = 0; $line_name = "goto_steps 0, ! ----> room <---- "; # declare goto_steps property # --- object name property (with , because of comments) --- $in_name = $room{$possible_room.$room_name[3]}; @name_list = split(/ /,$in_name); # list of all name properties of room if ($in_name ne "") { if ($in_name !~ /&.*/) { # if not marked as not unique $line_name = $line_name."\n name "; foreach $parse_name (@name_list) { if ($parse_name ne "") { $line_name = $line_name." \"$parse_name\""; } } $line_name = $line_name.","; # COMMA of name-property } else { # if not unique room could be in @go_to_rooms $member = 0; foreach $element (@go_to_rooms) { if ($element eq $possible_room) { $member = 1; } } if ($member == 1) { # if it *is* in @to_to_rooms $line_name = $line_name."\n name"; foreach $parse_name (@name_list) { if (($parse_name ne "") && ($parse_name ne "&")) { $line_name = $line_name." \"$parse_name\""; } } $line_name = $line_name.", ! >#>#> goto <#<#<"; # COMMA of name-property } else { $line_name = $line_name."\n ! ##### name"; # COMMA of name-property foreach $parse_name (@name_list) { if (($parse_name ne "") && ($parse_name ne "&")) { $line_name = $line_name." \"$parse_name\""; } } $line_name = $line_name." not unique #####"; } } # end of if not unique } # end of name property (in_name ne "") } # end of "with" recognized $line =~ s/\bwith\b/with $line_name\n$line_rest/io; # compose line again } } # end of obj to adjust print COPYFILE "$line\n"; # print the line, whether adjusted or not } # end of not commented lines } # Loop für while INFORMFILE } # --------- end of subroutine -------- if ($copy_flag eq "on") { # STATUS print "\nCopying files out of the file '$inform' to '$inform$copyfile_suffix'\n"; $i=1; # index counter for rooms foreach $room (@room_list) { $room_list_hash{$room} = $i++; # init hash field } $room_number=-1; # initialize room counter (-1 for no room) while ( ($input_file, $dummy) = each %room_file_history) { # loop through all examined files $skip_nonfile = "false"; # for skipping nonexistent files unless (open(INFORMFILE, $input_file)) { die ("Cant't open $input_file for some strange reason..."); } unless (open(COPYFILE, ">$input_file$copyfile_suffix")) { die ("Can't write to output file '$outfile'\n"); } print "Reading '$input_file' and writing '*$copyfile_suffix'\n"; ©_inform_file_loop; # copy the whole information from the file close(INFORMFILE); # close it close(COPYFILE); # close output file } } # STATUS print "\nDone\n"; ####################### end of mk_room_name ########################