program HKCEE_App_v063; //0.6.3 : updated web page bottom, fixed bug - forget to Caps name after space AND yr. of grad. check after edit age const max = 255; var m, f, numofpeople, i, table_id : integer; year, minyr, month, day, hour, minute, table_max : integer; //Date manager name, sex, men, women, table, first, last : array [1..max] of string; //Name, sex grad, age : array [1..max] of integer; //Yr of Grad., age emp : array [1..max] of char; //employment status option : char; xportit, show : boolean; //xport as html/show address? t : TimeStamp; location, choice : string; //database related db : text; txt, loaded : boolean; //db handling preference : array [1..5] of string; //Preference (* Procedures for all variables *) procedure convert(var tempstring : string); begin if (tempstring = 'Y') or (tempstring = 'y') or (tempstring = '+') then tempstring := 'Y' else if (tempstring = 'N') or (tempstring = 'n') or (tempstring = '-') then tempstring := 'N'; end; procedure backtohome(var pass : boolean); var tempstring : string; begin repeat write('Are you sure want to stop creating new record?(Y/N) '); readln(tempstring); convert(tempstring); if (tempstring = 'Y') then pass := true else if (tempstring = 'N') then pass := false //Force user to type name again else writeln('ERROR: Please choose from Yes(Y) or No(N)'); until (tempstring = 'Y') or (tempstring = 'N'); end; Procedure initialize; begin m := 0; f := 0; numofpeople := 0; for i := 1 to max do begin name[i] := ''; sex[i] := ''; men[i] := ''; women[i] := ''; grad[i] := 0; age[i] := 0; emp[i] := ' '; end; xportit := FALSE; show := false; i := 0; loaded := false; end; (* Procedure for Application *) Procedure date(var year, month, day, hour, minute : integer); var t: TimeStamp; begin GetTimeStamp (t); year := t.Year; month := t.Month; day := t.Day; hour := t.Hour; minute := t.Minute; end; procedure namecheck(var tempname : string; var pass : boolean); var j : integer; begin pass := true; for j := 1 to length(tempname) do begin if ((tempname[j] >= 'A') and (tempname[j] <= 'Z')) or ((tempname[j] >= 'a') and (tempname[j] <= 'z')) or ((tempname[j] = ' ') and (tempname[j+1] <> ' ') and (tempname[1] <> ' ')) then //Valid character, no more 2 space together begin if ((tempname[j] >= 'A') and (tempname[j] <= 'Z')) then //convert all characters into lower case tempname[j] := chr(ord(tempname[j]) + 32); if ((tempname[1] >= 'a') and (tempname[1] <= 'z')) then //convert first letter into caps. tempname[1] := chr(ord(tempname[1]) - 32); if (tempname[j-1] = ' ') and ((tempname[j] >= 'a') and (tempname[j] <= 'z')) then //convert after space into caps. tempname[j] := chr(ord(tempname[j]) - 32) end else //invalid character pass := false; end; end; procedure reg; var location, tempstring : string; //location of preference pref : text; //file code i, prefend, code, mailength : integer; //counter and pref. End point, sn at_check, dot_check, domain_check, mail, pass, mailid : boolean; //check if email address valid begin assign(pref, 'prefs.txt'); //load prefs.txt into variable "pref" {$I-} //Turns off System interrupt to prevent Segmentation Fault. reset(pref); //open file {$I+} //Turns on System Interrupt if IORESULT <> 0 then //if file does not exist begin rewrite(pref); //create file close(pref); preference[5] := '2'; //system preset: if there were no prefs before, choose TXT end; reset(pref); i := 0; while NOT eof(pref) do //read the whole file begin i := i + 1; readln(pref, preference[i]); end; close(pref); if (preference[1] <> '1') or (option = '8') then //if file is blank/user request to change begin writeln('Please register this application.'); preference[1] := '1'; //Pref. setted. repeat write('User name: '); readln(preference[2]); if preference[2] = '' then writeln('ERROR: Please enter your user name') else begin namecheck(preference[2], pass); if pass = false then writeln('ERROR: Invalid character(s) in user name.'); end; until (preference[2] <> '') and (pass = true); repeat repeat write('Email address: '); readln(preference[3]); mail := false; i := 0; mailength := length(preference[3]); if (mailength < 7) then writeln('ERROR: Email address is too short.'); until (mailength >= 7); //7 = a@b.com repeat i := i + 1; if (((preference[3][i] >= 'a') and (preference[3][i] <= 'z')) or ((preference[3][i] >= 'A') and (preference[3][i] <= 'Z')) or ((preference[3][i] >= '0') and (preference[3][i] <= '9')) or (preference[3][i] = '_') or (preference[3][i] = '.')) and (preference[3][1] <> '.') and (preference[3][1] <> '_') then // supported characters mailid := true else mailid := false; until (preference[3][i+1] = '@') or (mailid = false) or (i = mailength); repeat i := i + 1; if (preference[3][i] = '@') and (i > 1) and (preference[3][i+1] <> '@') then //check if "@" symbol is part of email address. at_check := true //Pass stage one - Check for @ symbol else at_check := false; until (at_check = TRUE) or (i = mailength); if i <> mailength then repeat i := i + 1; if (preference[3][i] = '.') and (((preference[3][i-1] >= 'a') and (preference[3][i-1] <= 'z')) or ((preference[3][i-1] >= 'A') and (preference[3][i-1] <= 'Z')) or ((preference[3][i-1] >= '0') and (preference[3][i-1] <= '9'))) then dot_check := true //pass stage two - check for a dot to seprate host name and domain name else dot_check := false; until (dot_check = true) or (i = mailength); if i <> mailength then repeat i := i + 1; if (ord(preference[3][i]) >= 97) and (ord(preference[3][i]) <= 122) and (ord(preference[3][i+1]) >= 97) and (ord(preference[3][i+1]) <= 122) then domain_check := TRUE //pass stage three - check for domain name(at least two characters, like .hk) else domain_check := FALSE; until (domain_check = TRUE) or (i = mailength); if (mailid = true) and (at_check = TRUE) and (dot_check = TRUE) and (domain_check = TRUE) then mail := true //valid email address? else mail := false; if mail = false then writeln('ERROR: Please enter a correct email address.'); until mail = true; repeat write('Show user name and email address in web page?(Y/N) '); readln(preference[4]); convert(preference[4]); until (preference[4] = 'Y') or (preference[4] = 'N'); if (preference[4] = 'Y') then show := TRUE else show := FALSE; end; rewrite(pref); for i := 1 to 5 do writeln(pref, preference[i]); close(pref); end; //END of procedure "register software" procedure prefs; var choice : string; prefs : text; begin repeat writeln('1. Register this software'); writeln('2. Change default database format'); writeln('3. Return to main menu'); write('Option: '); readln(choice); if choice = '1' then begin writeln(' ------------------------Register this software------------------------'); reg; writeln(' ----------------------------------------------------------------------'); end else if choice = '2' then begin repeat writeln; writeln('Please select a default format for database: '); writeln('1. CSV'); writeln('2. TXT'); write('Option: '); readln(preference[5]); writeln; if (preference[5] = '1') then txt := false else if (preference[5] = '2') then txt := true else writeln('ERROR: No such option.'); until (preference[5] = '1') or (preference[5] = '2'); end else if (choice <> '-x') and (choice <> '3') then writeln('ERROR: No such option.'); until (choice = '3') or (choice = '-x'); assign(prefs, 'prefs.txt'); rewrite(prefs); for i := 1 to 5 do writeln(prefs, preference[i]); close(prefs); end; (* Procedures for file handling *) procedure storeDB; var format : string; begin format := location[(length(location) - 3)..(length(location))]; //the last 4 characters of the file name if (format <> '.txt') and (format <> '.TXT') and (format <> '.CSV') and (format <> '.csv') then location := location + '.txt'; //assume, or FORCE the db store in TXT location := location[1..(length(location) - 4)] + '.txt'; //erase the extension, create it into TXT assign(db, location); rewrite(db); writeln(db, 'RTDB+'); for i := 1 to numofpeople do begin writeln(db, name[i]); writeln(db, first[i]); writeln(db, last[i]); writeln(db, sex[i]); writeln(db, age[i]); writeln(db, grad[i]); writeln(db, emp[i]); end; close(db); location := location[1..(length(location) - 4)] + '.csv'; //erase the extension, create it into CSV assign(db, location); rewrite(db); writeln(db, 'Registration Table Database;;;;;;'); writeln(db, 'Name;First Name;Last Name;Sex;Age;Year of Graduation;Employment Status'); for i := 1 to numofpeople do writeln(db, name[i], ';', first[i], ';', last[i], ';', sex[i], ';', age[i], ';', grad[i], ';', emp[i]); close(db); end; procedure load; var vers, tempstring, tempint, tempdata, format, choice : string; i, j, index : integer; begin repeat writeln('Press "return" for default location. ("-x" to exit)'); write('Load: '); readln(tempstring); if tempstring = '-x' then exit else if (tempstring = '') and (preference[5] = '2') then location := 'database.txt' else if (tempstring = '') and (preference[5] = '1') then location := 'database.csv' else if (length(tempstring) > 4) then begin format := tempstring[(length(tempstring)-3)..(length(tempstring))]; if (format = '.TXT') or (format = '.txt') or (format = '.csv') or (format = '.CSV') then location := tempstring else writeln('ERROR: File extension is missing or not supported.'); end else writeln('ERROR: File extension is missing.'); until (tempstring = '') or (format = '.TXT') or (format = '.txt') or (format = '.csv') or (format = '.CSV'); assign(db, location); {$I-} reset(db); {$I+} if (IORESULT <> 0) then //not found? begin writeln; writeln('ERROR: File "', location, '" not found.'); location := ''; end else //found it. opened. begin if (loaded = true) then repeat write('Do you want to merge the current database with it?(Y/N) '); readln(choice); convert(choice); if (choice <> 'Y') and (choice <> 'N') then writeln('ERROR: No such option. Please choose from Yes(Y) or No(N)') else if (choice = 'Y') then i := numofpeople else if (choice = 'N') then begin for i := 1 to numofpeople do begin name[i] := ''; first[i] := ''; last[i] := ''; sex[i] := ''; age[i] := 0; grad[i] := 0; emp[i] := ''; end; i :=0; numofpeople := 0; end; until (choice = 'Y') or (choice = 'N') else i := 0; readln(db, vers); //read the file format. Check if it's compatable with the programme. if (vers = 'RTDB+') then //If it loads a text file begin write('Loading'); while NOT EOF(db) do begin i := i + 1; readln(db, name[i]); readln(db, first[i]); readln(db, last[i]); readln(db, sex[i]); readln(db, age[i]); readln(db, grad[i]); readln(db, emp[i]); write('.');//just eye candy for loading, or you may count it to see how many records. end; numofpeople := i; writeln('Done!'); storeDB; loaded := true; end else if (vers = 'Registration Table Database;;;;;;') then //if it loads a CSV file begin readln(db, tempdata); //next line to data write('Loading'); while NOT EOF(db) do begin i := i + 1; write('.'); readln(db, tempdata); j := 0; tempstring := ''; repeat j := j + 1; tempstring := tempstring + tempdata[j]; until (tempdata[j] = ';'); name[i] := tempstring[1..(length(tempstring) - 1)]; tempstring := ''; repeat j := j + 1; tempstring := tempstring + tempdata[j]; until (tempdata[j] = ';'); first[i] := tempstring[1..(length(tempstring) - 1)]; tempstring := ''; repeat j := j + 1; tempstring := tempstring + tempdata[j]; until (tempdata[j] = ';'); last[i] := tempstring[1..(length(tempstring) - 1)]; tempstring := ''; repeat j := j + 1; tempstring := tempstring + tempdata[j]; until (tempdata[j] = ';'); sex[i] := tempstring[1..(length(tempstring) - 1)]; tempint := ''; repeat j := j + 1; tempint := tempint + tempdata[j]; until (tempdata[j] = ';'); tempint := tempint[1..(length(tempint) - 1)]; val(tempint, age[i], index); tempint := ''; repeat j := j + 1; tempint := tempint + tempdata[j]; until (tempdata[j] = ';'); tempint := tempint[1..(length(tempint) - 1)]; val(tempint, grad[i], index); j := j + 1; if (tempdata[j] = 's') then tempdata[j] := 'S' else if (tempdata[j] = 'e') then tempdata[j] := 'E' else if (tempdata[j] = 'u') then tempdata[j] := 'U' else if (tempdata[j] = 'r') then tempdata[j] := 'R'; emp[i] := tempdata[j]; numofpeople := i; end; writeln('Done!'); storeDB; loaded := true; end else begin writeln; if format = '.txt' then writeln('Incompatible text file!') else if format = '.csv' then writeln('Incompatible or damaged CSV file!'); end; close(db); end; end; procedure create; var firstname, lastname, conc, tempstring, tempsex, tempemp, format : string; i, maxyr, minyr, xport, j, tempage, tempgrad : integer; db : text; pass : boolean; begin if (location = '') then begin writeln('What is the file name of the database to be created? ("-x" to exit)'); write('Location: '); readln(tempstring); if (tempstring = '-x') then exit else begin format := tempstring[(length(tempstring) - 3)..(length(tempstring))]; //the last 4 characters of the file name if (format <> '.TXT') and (format <> '.txt') and (format <> '.CSV') and (format <> '.csv') then location := tempstring + '.txt' else location := tempstring; end end; if numofpeople < 1 then //check if DB loaded i := 0 else i := numofpeople; repeat writeln('Record #', i+1); //since the record is not logged, i is still 0. pass := false; //erase previous data repeat //name first write('First Name: '); readln(firstname); if (firstname = '-x') then begin backtohome(pass); if pass = true then // if return value "pass" = true then exit procedure exit end else begin if (length(firstname) < 2) then writeln('ERROR: Not enough character for first name.') else begin namecheck(firstname, pass); if (pass = false) then writeln('ERROR: Invalid character in first name'); end; end; until (pass = TRUE); pass := false; //erase previous data repeat //name first write('Last Name: '); readln(lastname); if (lastname = '-x') then begin backtohome(pass); if pass = true then // if return value "pass" = true then exit procedure exit end else begin if length(lastname) < 2 then writeln('ERROR: Not enough character for last name.') else begin namecheck(lastname, pass); if (pass = false) then writeln('ERROR: Invalid character in last name'); end; end; until (pass = TRUE); pass := false; repeat //sex write('Sex(M/F): '); readln(tempsex); if (tempsex = '-x') then begin backtohome(pass); if pass = true then exit end else begin if (tempsex[1] = 'm') or (tempsex[1] = 'f') then //compiler force me to make it into char. it's stupid to do more on it. tempsex[1] := chr(ord(tempsex[1]) - 32); // so I force the compiler to treat it as char! if (tempsex <> 'M') then if (tempsex <> 'F') then writeln('ERROR: Input must be "M" or "F"'); end; until ((tempsex = 'M') or (tempsex = 'F')); repeat //age write('Age: '); readln(tempstring); if (tempstring = '-x') then begin backtohome(pass); if pass = true then exit end; val(tempstring, tempage, xport); //from, to, checker if (xport <> 0) then writeln('ERROR: Please input an integer.') else if (xport = 0) and ((tempage < 15) or (tempage > 110)) then writeln('ERROR: Age must be 15-110') until ((tempage >= 15) and (tempage <= 110)) and (xport = 0); repeat //yr of grad conc := 'N'; write('Year of Graduation: '); readln(tempstring); //20-15=5(max left sch 5 yrs ago) if (tempstring = '-x') then begin backtohome(pass); if pass = true then exit end; val(tempstring, tempgrad, xport); //from, to, checker if (xport <> 0) then writeln('ERROR: Please input an integer.'); minyr := year - (tempage - 15); maxyr := year - (tempage - 21); if (maxyr > year) then maxyr := year; if ((tempgrad < minyr) or (tempgrad > maxyr)) and (xport = 0) then writeln('ERROR: out of range. It must be ', minyr, '-', maxyr) else if (xport = 0) then conc := 'Y'; until (conc = 'Y'); repeat //employment write('Employment Status (Studying(S), Employed(E) , Unemployed(U) , Retired(R) ): '); readln(tempemp); if (tempemp = '-x') then begin backtohome(pass); if pass = true then exit end; if (tempemp[1] = 's') or (tempemp[1] = 'e') or (tempemp[1] = 'u') or (tempemp[1] = 'r') then tempemp := chr(ord(tempemp[1]) - 32); if (tempemp <> 'S') then if (tempemp <> 'E') then if (tempemp <> 'U') then if (tempemp <> 'R') then writeln('ERROR: Input must be "S", "E" , "U" or "R"'); until ((tempemp = 'S') or (tempemp = 'E') or (tempemp = 'U') or (tempemp = 'R')); repeat //continue write('Continue(C) or Stop(S)? '); readln(conc); if (conc = '-x') then begin backtohome(pass); if pass = true then exit end; if (conc = 'c') or (conc = 's') then conc[1] := chr(ord(conc[1]) - 32); if (conc <> 'C') and (conc <> 'S') then writeln('ERROR: Please choose from Continue(C) or Stop(S)'); until ((conc = 'C') or (conc = 'S')); if conc = 'C' then writeln; //make a space to seprate if user pause entering data. Just some Eye candy. i := i + 1; name[i] := firstname + ' ' + lastname; //put the data back first[i] := firstname; last[i] := lastname; age[i] := tempage; sex[i] := tempsex; grad[i] := tempgrad; emp[i] := tempemp; numofpeople := i; until (conc = 'S'); storeDB; end; (* Procedures for data handling *) procedure sortbyage; var i, j, tempage, tempgrad : integer; tempname, tempsex, tempfirst, templast : string; tempemp : char; begin i := 0; for j := numofpeople downto 1 do for i := 1 to j-1 do if age[i] > age[i+1] then begin //copy tempage := age[i+1]; tempname := name[i+1]; tempfirst := first[i+1]; templast := last[i+1]; tempsex := sex[i+1]; tempgrad := grad[i+1]; tempemp := emp[i+1]; //overwrite age[i+1] := age[i]; name[i+1] := name[i]; first[i+1] := first[i]; last[i+1] := last[i]; sex[i+1] := sex[i]; grad[i+1] := grad[i]; emp[i+1] := emp[i]; //paste age[i] := tempage; name[i] := tempname; first[i] := tempfirst; last[i] := templast; sex[i] := tempsex; grad[i] := tempgrad; emp[i] := tempemp; end; end; procedure splitsex; var i : integer; begin m := 0; f := 0; for i := 1 to numofpeople do if sex[i] = 'M' then begin m := m + 1; men[m] := name[i]; end else begin f := f + 1; women[f] := name[i]; end; end; (* Procedures for xport and viewing data *) procedure generate(num_of_men, num_of_women : integer); var gp1, gp2 : array[1..max] of string; people_id, num_of_gp1, num_of_gp2, plus, gp2_per_table, remain, counter, num_of_std_table_with_gp2, gp2_table_mini, table_shares_remain_gp2, track : integer; check_point : boolean; begin if num_of_men >= num_of_women then //num_of_men = 'm', num_of_women = 'f' begin for people_id := 1 to num_of_men do //men -> gp1 gp1[people_id] := men[people_id]; for people_id := 1 to num_of_women do //women -> gp2 gp2[people_id] := women[people_id]; num_of_gp1 := num_of_men; num_of_gp2 := num_of_women; end else if num_of_women > num_of_men then //num_of_women > num_of_men begin for people_id := 1 to num_of_women do //women -> gp1 gp1[people_id] := women[people_id]; for people_id := 1 to num_of_men do //men -> gp2 gp2[people_id] := men[people_id]; num_of_gp1 := num_of_women; num_of_gp2 := num_of_men; end; //end of copying into array. people_id := 0; //RESET!! for table_id := 1 to 255 do table[table_id] := ''; table_max := num_of_gp1 div 4; //No. of table plus := num_of_gp1 mod 4; //Table with one more gp1 counter := 0; //Assign people counter: Assign 4 people each table by default. gp2_per_table := num_of_gp2 div table_max; //no. of gp2 people each table table_shares_remain_gp2 := num_of_gp2 mod table_max; //no. of table that shares the remained GP2 people if plus = 0 then //If there's no table with more people from gp1, run this for table_id := 1 to table_max do begin repeat people_id := people_id + 1; //jump to next one counter := counter + 1; //remember to jump to next table when there is 4 people table[table_id] := table[table_id] + gp1[people_id] + ', '; //e.g. "Mack Wong, " until counter = 4; //enough! next table. counter := 0; end else if plus > 0 then //if there were some table with 5 people begin for table_id := 1 to table_max - plus do //from #1 to last table with 4 people. begin repeat //need modification? plus > people_id?// people_id := people_id + 1; //jump to next one counter := counter + 1; //remember to jump to next table when there is 4 people table[table_id] := table[table_id] + gp1[people_id] + ', '; //e.g. "Mack Wong, " until counter = 4; counter := 0; end; for table_id := table_max - plus + 1 to table_max do //from "last table with 4 people + 1" begin //(first table with more ppl) to last table repeat people_id := people_id + 1; counter := counter + 1; table[table_id] := table[table_id] + gp1[people_id] + ', '; until counter = 5; counter := 0; end; end; people_id := 0; //initialize locaters. table_id := 0; //initialize locaters. counter := 0; repeat table_id := table_id + 1; if gp2_per_table > 0 then repeat people_id := people_id + 1; table[table_id] := table[table_id] + gp2[people_id] + ', '; counter := counter + 1; until counter = gp2_per_table //put correct amount of gp2 ppl first. else check_point := true; COUNTER := 0; if table_shares_remain_gp2 > 0 then //check if it's necessary to put 1 more begin people_id := people_id + 1; table[table_id] := table[table_id] + gp2[people_id] + ', '; table_shares_remain_gp2 := table_shares_remain_gp2 - 1; end; until ((table_id = table_max) or (check_point = true)) and (table_shares_remain_gp2 = 0); //table_id = max (for normal situation) or check_point = true(if some table had no gp2 ppl) + all remainder gone. track := 0; for table_id := 1 to table_max do begin writeln('Table #', table_id); table[table_id] := copy(table[table_id], 1, length(table[table_id]) - 2); //cut the last 2 unnecessary characters track := track + 1; writeln(table[table_id]); if (table_id <> table_max) then writeln; if (track = 5) then begin write('Press "return" to continue...'); readln; track := 0; end; end; xportit := TRUE; end; procedure list; var j, i, spacer, pause : integer; begin m := 0; f := 0; i := 0; writeln(' # Name Sex Age Year Of Graduation Employment status'); repeat pause := 0; repeat i := i + 1; pause := pause + 1; write(i:3, ' '); spacer := 23 - length(name[i]); write(name[i]); for j := 1 to spacer do //give enough amount of space write(' '); write(sex[i], ' '); if sex[i] = 'M' then //counter for data needed at the end of this procedure m := m + 1 else f := f + 1; write(age[i]:3, ' '); write(grad[i], ' '); if emp[i] = 'S' then write('Studying') else if emp[i] = 'E' then write('Employed') else if emp[i] = 'U' then write('Unemployed') else write('Retired'); writeln; until (pause = 21) or (i = numofpeople); if (i <> numofpeople) then begin write('Press "return" to continue...'); readln; end; until (i = numofpeople); writeln; writeln('Number of Guests: ', numofpeople, ' Number of Male: ', m, ' Num of Female: ', f); end; procedure xport; var webpage : text; filename, sources, pagetitle, tempday, tempmonth, tempyear : string; page : string[100000]; header, data, rounder, number : array [1..255] of string; i, templatemax, d, dd, m, mm, y, yy, yyy, yyyy, index : integer; stopper : boolean; begin if xportit = TRUE then begin i := 0; writeln('Press "return" for default setting. ("-x" to exit)'); write('Page title: '); readln(pagetitle); if pagetitle = '' then pagetitle := 'Seating Plan for dinner' else if (pagetitle = '-x') then exit; write('File Name: '); readln(filename); if filename = '' then filename := 'site/index.html' else if (filename = '-x') then exit else begin if (filename[(length(filename) - 4) .. (length(filename)-1)] <> '.html') and (filename[(length(filename) - 4) .. (length(filename)-1)] <> '.HTML') then filename := filename + '.html'; writeln('Remember to copy the folder "images" from "site" to your selected directory.'); end; assign(webpage, filename); {$I-} rewrite(webpage); {$I+} if IORESULT <> 0 then begin writeln('-------------------------Output Error-------------------------':71); writeln('| ERROR: Could not create document. Please check whether the |':71); writeln('| folder is exist or the volume is writable. |':71); writeln('--------------------------------------------------------------':71); end else begin str(day, tempday); str(month, tempmonth); str(year, tempyear); if (day < 10) then tempday := '0' + tempday; if (month <10) then tempmonth := '0' + tempmonth; val(tempday[1], d, index); val(tempday[2], dd, index); val(tempmonth[1], m, index); val(tempmonth[2], mm, index); val(tempyear[1], y, index); val(tempyear[2], yy, index); val(tempyear[3], yyy, index); val(tempyear[4], yyyy, index); number[1] := ''; number[2] := ''; number[3] := ''; number[4] := ''; number[5] := ''; number[6] := ''; number[7] := ''; number[8] := ''; number[9] := ''; number[10] := ''; number[11] := ''; write('Exporting'); for i := 1 to 25 do begin header[1] := ''; header[2] := ' '; header[3] := ' '; header[4] := ' ' + pagetitle + ''; header[5] := ' '; header[6] := ' '; header[7] := ' '; header[8] := ' '; header[9] := ' '; header[10] := ' '; header[11] := ' '; header[22] := ' '; header[23] := ' '; header[24] := ' '; header[25] := ' '; rounder[5] := ' '; rounder[6] := ' '; rounder[7] := ' '; rounder[8] := ' '; rounder[9] := ' '; rounder[13] := ' '; rounder[14] := ' '; rounder[15] := '
 
'; header[12] := ' '; header[13] := ' '; header[14] := ' '; header[15] := ' '; header[16] := ' '; header[19] := ' '; header[20] := '
'; header[17] := number[d+1] + number[dd+1] + number[11] + number[m+1] + number[mm+1]; header[18] := number[11] + number[y+1] + number[yy+1] + number[yyy+1] + number[yyyy+1] + '
'; header[21] := '
 
'; write('.'); //eye candy if (i = 16) or (i = 17) then //just eye candy. export it better write(webpage, header[i]) else writeln(webpage, header[i]); end; for table_id := 1 to table_max do begin data[1] := ' '; data[2] := ' '; data[3] := ' '; data[4] := ' '; data[5] := ' '; data[6] := ' '; data[7] := ' '; data[8] := '
Table #' + chr(table_id+48) + '
' + table[table_id] + '
'; data[9] := '

'; for i := 1 to 9 do begin write('.'); writeln(webpage, data[i]); end; end; if (preference[4] = 'Y') then begin write(webpage, '

Generated by '); write(webpage, preference[2]); //name writeln(webpage, ''); end; for i := 1 to 17 do begin rounder[1] := '

 

'; rounder[2] := '


'; rounder[3] := '

'; rounder[4] := '
 
 
'; rounder[10] := '

'; rounder[11] := '

Best viewed with Safari and FireFox web browser.

'; rounder[12] := '
 
'; rounder[16] := ' '; rounder[17] := ' '; write('.'); writeln(webpage, rounder[i]); end; write('Done!'); writeln; end; close(webpage); end else writeln('ERROR: You must generate the Seating Plan before xporting.'); end; procedure Finder(var tempstring : string; var found : boolean; var target : integer); //Finder - search for record for "delete" and "edit" var i, track : integer; answer : string; begin//begin search name track := 0;//track is for checking how many guest the search looked for. Just for better grammar for i := 1 to (length(tempstring)) do begin if (tempstring[i] <> ' ') or (i = 1) then //do not change the word after space begin if (tempstring[i] >= 'A') and (tempstring[i] <= 'Z') then tempstring[i] := chr(ord(tempstring[i]) + 32); //convert a single char. into lower case if (tempstring[1] >= 'a') and (tempstring[1] <= 'z') then tempstring[1] := chr(ord(tempstring[1]) - 32); if (tempstring[i-1] = ' ') and (tempstring[i] >= 'a') and (tempstring <= 'z') then //for those after space with lower case tempstring[i] := chr(ord(tempstring[i]) - 32); end; end; i := 0; repeat i := i + 1; if (tempstring[1..length(tempstring)] = name[i][1..length(tempstring)]) then //if first name=same then begin found := true; repeat write('Do you mean "', name[i], '"?(Y/N) '); //ask user if he/she is looking for this record readln(answer); convert(answer); if (answer = 'Y') then begin found := true; target := i; writeln; end else if (answer = 'N') then begin track := track + 1; found := false end else writeln('ERROR: Please choose from Yes(Y) or No(N)'); until (answer = 'Y') or (answer = 'N'); end else found := false; until (i = numofpeople) or (found = TRUE); end;//end of search name procedure viewer(var target : integer); //procedure for viewing data for both "delete" and "edit" begin writeln('--------------------------------------------------'); writeln('Record #', target); writeln('Name: ', name[target]); writeln('First: ', first[target]); writeln('Last: ', last[target]); writeln('Sex: ', sex[target]); writeln('Age: ', age[target]); writeln('Year of Graduation: ', grad[target]); write('Employment status: '); if emp[target] = 'S' then writeln('Studying') else if emp[target] = 'E' then writeln('Employed') else if emp[target] = 'U' then writeln('Unemployed') else if emp[target] = 'R' then writeln('Retired'); writeln('--------------------------------------------------'); end; procedure delete; var target, index, track : integer; tempstring, holder : string; found : boolean; begin writeln(' --------------Commands for Deleting data from database--------------'); writeln(' | * Show all records |'); writeln(' | -x Back to Main screen |'); writeln(' | n Delete record #n (n is the record ID that you want to delete)|'); writeln(' --------------------------------------------------------------------'); repeat i := 0; writeln('Type the characters that the guest name starting with or Record ID to delete.'); write('Delete: '); readln(tempstring); //read data if (tempstring = '*') then //list begin writeln('--------------------------------------------------------------------------------'); list; writeln('--------------------------------------------------------------------------------'); end else if (tempstring > '0') or ((tempstring >= 'A') and (tempstring <= 'Z')) or ((tempstring >= 'a') and (tempstring <= 'z')) and (tempstring[1] <> ' ') and (tempstring <> '') then begin val(tempstring, target, index); if (index = 0) then //an integer found := true else if (tempstring <> '*') and (index <> 0) then finder(tempstring, found, target); //moved to "Finder"!!! The engine is shared with Edit now (055) if (found = true) and (target <= numofpeople) then begin viewer(target); //core moved to procedure! (055) repeat write('Are you sure want to delete this record?(Y/N) '); readln(tempstring); convert(tempstring); if (tempstring = 'Y') then begin for i := target to numofpeople-1 do begin name[i] := name[i+1]; first[i] := first[i+1]; last[i] := last[i+1]; sex[i] := sex[i+1]; grad[i] := grad[i+1]; age[i] := age[i+1]; emp[i] := emp[i+1]; if sex[target] = 'M' then m := m - 1 //deletion of name from "men" is not necessary because else //this program doesnt list only men. Re-gen will perform next time and erased this record. f := f - 1; //this action is just for correcting data for "list" here. end; numofpeople := numofpeople - 1; //as above, correction for "list" here writeln; writeln('Record #', target, ' deleted!'); writeln; end else if (tempstring = 'N') then begin writeln('----------------------Note----------------------':64); //:64 is for centering the box writeln('| Action cancelled. Data remain untouched. |':64); writeln('------------------------------------------------':64); end else begin writeln('ERROR: Please choose from Yes(Y) or No(N)'); end; until (tempstring = 'Y') or (tempstring = 'N'); end else begin if(target <= numofpeople) and (tempstring <> '-x')then //if it's user search and not found if (track > 0) then writeln('Sorry. No more guest found with name starting with "', tempstring, '"') else writeln('Sorry. No guest found with name starting with "', tempstring, '"') else if (index = 0) then //not user search = enter code begin writeln('Sorry. No guest with ID#', target, '.'); writeln; end; end end else if (tempstring = '-x') then exit else writeln('ERROR: No such option.'); storeDB; until (tempstring = '-x');; end; procedure edit; var target, index, track, i, temp, minyr, maxyr, tempageI, tempgradI : integer; tempstring, holder, tempfirst, templast, tempsex, tempage, tempgrad, tempemp, editit : string; found, pass, stop : boolean; begin writeln(' --------------Commands for Editing data from database---------------'); writeln(' | * Show all records |'); writeln(' | -x Back to Main screen |'); writeln(' | n Edit record #n (n is the record ID that you want to edit) |'); writeln(' --------------------------------------------------------------------'); repeat i := 0; writeln('Type the characters that the guest name starting with or Record ID to edit.'); write('Edit: '); readln(tempstring); //read data if (tempstring = '-x') then exit else if (tempstring = '*') then //list begin writeln('--------------------------------------------------------------------------------'); list; writeln('--------------------------------------------------------------------------------'); end else if (tempstring > '0') or ((tempstring >= 'A') and (tempstring <= 'Z')) or ((tempstring >= 'a') and (tempstring <= 'z')) and (tempstring[1] <> ' ') and (tempstring <> '') then begin val(tempstring, target, index); if (index = 0) then //an integer found := true else if (tempstring <> '*') and (index <> 0) then //not listing -> name search finder(tempstring, found, target); //moved to "Finder"!!! The engine is shared with Edit now (055) if (found = true) and (target <= numofpeople) then begin viewer(target); //core moved to procedure! (055) show info repeat write('Edit this record?(Y/N) '); readln(editit); convert(editit); if editit = 'N' then stop := true else if (editit = 'Y') then stop := false; until (editit = 'Y') or (editit = 'N'); if stop = false then repeat //process firstname pass := false; write('First name: ', first[target], ' -> '); readln(tempfirst); if (tempfirst = '') then begin tempfirst := first[target]; //if there's no change, copy the original value into temp. pass := true; //stop editing end else if (tempfirst = '-x') then begin stop := true; pass := true; end else if ((tempfirst >= 'A') and (tempfirst <= 'Z')) or ((tempfirst >= 'a') and (tempfirst <= 'z')) and (tempfirst[1] <> ' ') then begin for i := 1 to length(tempfirst) do begin if (tempfirst[i] >= 'A') and (tempfirst[i] <= 'Z') and (tempfirst[i] <> ' ')then tempfirst[i] := chr(ord(tempfirst[i]) + 32); //lower it al if (tempfirst[i-1] = ' ') then tempfirst[i] := chr(ord(tempfirst[i]) - 32); //upper after space if (tempfirst[1] >='a') and (tempfirst[1] <= 'z') then tempfirst[1] := chr(ord(tempfirst[1]) - 32); pass := true; end end else begin pass := false; writeln('ERROR: First name is invalid.'); end; until pass = TRUE; if stop = false then repeat //process lastname pass := false; write('Last name: ', last[target], ' -> '); readln(templast); if (templast = '') then begin pass := true; templast := last[target] end else if (templast = '-x') then begin pass := true; stop := true; end else if ((templast >= 'A') and (templast <= 'Z')) or ((templast >= 'a') and (templast <= 'z')) and (templast[1] <> ' ') then begin for i := 1 to length(templast) do begin if (templast[i] >= 'A') and (templast[i] <= 'Z') and (templast[i] <> ' ')then templast[i] := chr(ord(templast[i]) + 32); //lower it al if (templast[i-1] = ' ') then templast[i] := chr(ord(templast[i]) - 32); //upper after space if (templast[1] >='a') and (templast[1] <= 'z') then templast[1] := chr(ord(templast[1]) - 32); last[target] := templast; pass := true; end end else begin pass := false; writeln('ERROR: Last name is invalid.'); end; until pass = TRUE; if stop = false then repeat pass := true; write('Sex: ', sex[target], ' -> '); readln(tempsex); if(tempsex = '') then tempsex := sex[target] else if (tempsex = '-x') then stop := true else if (tempsex = 'M') or (tempsex = 'm') then tempsex := 'M' else if (tempsex = 'F') or (tempsex = 'f') then tempsex := 'F' else begin writeln('ERROR: Please choose from Male(M) or Female(F)'); pass := false; end; until pass = true; if stop = false then repeat //age pass := true; write('Age: ', age[target], ' -> '); readln(tempage); if (tempage = '') then begin tempageI := age[target]; //copy it into temp age pass := true end else if (tempage = '-x') then begin pass := true; stop := true; end else begin val(tempage, temp, index); if (index = 0) then //tempage is integer begin if (temp >= 15) and (temp <= 110) then tempageI := temp else begin pass := false; writeln('ERROR: Please input an integer.'); end; end; end; until pass = true; if stop = false then repeat //year of graduation pass := false; minyr := year - (tempageI - 15); maxyr := year - (tempageI - 21); write('Year of Graduation: ', grad[target], ' -> '); readln(tempgrad); if (tempgrad = '-x') then //exit? begin stop := true; pass := true; end else begin if (tempgrad = '') then //not exit -> use current data? str(grad[target], tempgrad); //convert original data, ready for next convertion...lazy habit. val (tempgrad, temp, index); if (index = 0) then //it is integer begin if (maxyr > year) then maxyr := year; if ((temp < minyr) or (temp > maxyr)) then writeln('ERROR: Out of range. It must be ', minyr, '-', maxyr) else begin tempgradI := temp; pass := true; end; end else writeln('ERROR: Please enter an integer.'); end; until pass = true; if stop = false then repeat pass := true; write('Employment status: '); if (emp[target] = 'E') then write('Employed(E) -> ') else if (emp[target] = 'U') then write('Unemployed(U) -> ') else if (emp[target] = 'S') then write('Studying(S) -> ') else write('Retired(R) -> '); readln(tempemp); if (tempemp[1] = 'E') or (tempemp[1] = 'e') then //once the first char. matches,got it. emp[target] := 'E' else if (tempemp[1] = 'U') or (tempemp[1] = 'u') then emp[target] := 'U' else if (tempemp[1] = 'S') or (tempemp[1] = 's') then emp[target] := 'S' else if (tempemp[1] = 'R') or (tempemp[1] = 'r') then emp[target] := 'R' else if (tempemp = '') then emp[target] := emp[target] //this is the last thing to modify. once return is pressed, it's stored and -x doesnt work at all. else if (tempemp = '-x') then stop := true else begin writeln('ERROR: Please choose from "Studying(S)", "Employed(E)", "Unemployed(U)" and "Retired(R)".'); pass := false; end; until pass = true; if stop = false then begin writeln('Record #', target, ' updated!'); first[target] := tempfirst; last[target] := templast; name[target] := first[target] + ' ' + last[target]; age[target] := tempageI; sex[target] := tempsex; grad[target] := tempgradI; storeDB; end; end; end else writeln('ERROR: No such option.'); until (tempstring = '-x'); end; begin //begin of program initialize; //initialize all local variables. date(year, month, day, hour, minute); //get today' date. reg; writeln(' =================================================================='); writeln(' Welcome to Registration table version 0.6.3! Please make a choice:'); writeln(' =================================================================='); repeat writeln('1. Load database...'); writeln('2. Create new record'); writeln('3. Edit record'); writeln('4. Delete record'); writeln('5. List all records'); writeln('6. Generate Seating Plan'); writeln('7. Export the result into web page'); writeln('8. Preference...'); writeln('9. About this programme'); writeln('0. Quit'); write('Option: '); readln(option); case option of '1' : begin writeln('=================================Database loader================================'); load; writeln('================================================================================'); end; '2' : begin writeln('===============================Create New Records==============================='); create; writeln('================================================================================'); end; '3' : begin writeln('===================================Edit Record=================================='); if (numofpeople > 0) then edit else writeln('ERROR: No record in database.'); writeln('================================================================================'); end; '4' : begin writeln('=================================Delete Record=================================='); if (numofpeople > 0) then delete else writeln('ERROR: No record in database.'); writeln('================================================================================'); end; '5' : begin writeln('==============================List current records=============================='); if (numofpeople > 0) then list else writeln('ERROR: No record in database.'); write('================================================================================'); readln; end; '6' : begin writeln('==================================Seating Plan=================================='); if numofpeople >= 24 then begin sortbyage; splitsex; generate(m, f); end else writeln('ERROR: Not enough people for annual dinner. Mininum requirement is 24 people.'); write('================================================================================'); readln; end; '7' : begin writeln('===============================Export as Web Page==============================='); xport; writeln('================================================================================'); end; '8' : begin writeln('=================================Set Preference================================='); prefs; writeln('================================================================================'); end; '9' : begin writeln('--------------------About this programme--------------------':70); writeln('| Registration table version 0.6.3 |':70); writeln('| This programme is written by Mack Wong Ho Hin. It is part|':70); writeln('| of his HKCEE CIT Programming Course Work. |':70); writeln('| The programme was written on a Mac and compiled with GNU |':70); writeln('| Pascal. For more information, please contact the writer. |':70); writeln('| Email: joewhk [at] yahoo [dot] com [dot] hk |':70); writeln('| Homepage: http://imack.no-ip.com/ |':70); writeln('------------------------------------------------------------':70); end; '0' : exit; else begin writeln; writeln('ERROR: No such option.'); writeln; end end; until (option = '0'); end.