⟦e6bf68ce5⟧

TextFile

program date(input, output, Questions, database, bbase);

(*
			Date-A-Base version 1.1
			       by
                         Thomas M. Johnson

			 john1233@csd4.milw.wisc.edu
				  or
                             tommyj@lakesys

     files used:
	   Questions - holds the questionaire
	   database  - all people registered with the Date-A-Base
		       and their information
           bbase     - data used by brouse command.

(c) 1987 Thomas M. Johnson *)




const
    NUMOFQUESTIONS = 49;
    STRINGLENGTH = 20;
    ONE = 1;
    LOW = 'a';

type
    string = packed array [ONE..STRINGLENGTH] of char;
    answerarray = packed array [ONE..NUMOFQUESTIONS] of char;
    userp = ^ usertype;
    usertype = 
	record 
	    login: string;
	    passwd: string;
	    sex: char;
	    timeson: integer;
	    answers: answerarray;
(*	    laston: integer;   *)
	    next: userp
	end;

var
    Questions: text;
    database: file of usertype;
    head: userp;
    static: usertype;
    bbase: text;
    continue: boolean;



    function cstrings(var string1: answerarray; string2: answerarray): real;

    (* The function cstrings takes 2 strings and compares them.
       cstrings then returns the percent identical the strings are.
       The strings are compared letter for letter and must be in the
       same place in the string.                               *)


    var
	counter: integer;
	percent: integer;

    begin
	percent := 0;

	for counter := ONE to NUMOFQUESTIONS do 
	    if string1[counter] = string2[counter] then 
		percent := percent + 1;
	cstrings := percent / NUMOFQUESTIONS * 100
    end; { cstrings }

    function yesNo: boolean;

    const
	yes = 'y';
	no = 'n';

    var
	ch: char;

    begin
	repeat
	    write(output, ' (y/n) ');
	    readln(input, ch)
	until (ch = yes) or (ch = no);
	yesNo := ch = yes

    end; { yesNo }



    function getanswer(ubound: char): char;

    (* The function getanswer reads in a character and checks to see
       if it is in the range of lobound to ubound. If it isn't, then the
       user is reprompted.                                          *)


    var
	tempchar: char;
	charindex: char;

    begin
	repeat
	    writeln(output);

	    for charindex := LOW to ubound do 
		write(output, charindex);

	    writeln(output);
	    write(output, 'Your choice: ');
	    readln(input, tempchar)
	until (tempchar >= LOW) and (tempchar <= ubound);

	writeln(output);
	getanswer := tempchar
    end; { getanswer }


    procedure readstring(var tempstring: string);

    (* read a string from standard input. the string must have
       a length of 2 or greater or it is invalid.   *)


    const
	init = 0;
	inc = 1;
	blank = '                    ';

    var
	ch: char;
	length: integer;

    begin
	repeat
	    tempstring := blank;
	    length := init;
	    while not eoln(input) do begin
		read(input, ch);
		length := length + inc;
		tempstring[length] := ch
	    end;
	    readln(input)
	until length > 1

    end; { readstring }

    procedure readint(var sum: integer);

    (* read in a string from standard input and convert to an
       integer.     *)


    const
	init = 0;
	inc = 1;
	base = 10;
	intlow = '0';
	inthigh = '9';

    var
	i: integer;
	done: boolean;
	hold: string;

    begin
	i := inc;
	done := false;
	sum := init;
	readstring(hold);
	while (i <= STRINGLENGTH) and not done do 
	    if (hold[i] < intlow) or (hold[i] > inthigh) then 
		done := true
	    else begin
		sum := sum * base + (ord(hold[i]) - ord(intlow));
		if sum > maxint then 
		    done := true
		else 
		    i := i + inc
	    end
    end; { readint }



    procedure printques(var quests: answerarray);

    (* prints the questions from the file Questions.
       the question file is set up like:
    
       The question
       the answers
    		   .
    		   .
    		   .
    		   .
       ^G (up limit)
    
       then ^G is just a marker to signify where the answers end.
       low limit is usually and 'a'
       up limit the the last answer
    
       *)

    var
	ch: char;
	uplimit: char;
	chset: set of char;
	i: integer;

    begin
	reset(Questions);
	i := 1;
	chset := ['A'..'Z', 'a'..'z', '0'..'9', '?', '.', ' ', '-', '/'];
	ch := ' ';
	while not eof(Questions) do begin
	    while not eoln(Questions) do begin
		read(Questions, ch);
		if ch in chset then 
		    write(output, ch)
		else begin
		    readln(Questions, uplimit);
		    quests[i] := getanswer(uplimit);
		    i := i + 1
		end
	    end;
	    readln(Questions);
	    writeln(output)
	end
    end; { printques }

    function Search(lookfor: string; var hisrec: usertype): boolean;

    (* scan the linked list to find a match between the string lookfor 
       and the .login field. If there is a match, a true is returned with
       the record of that person. Otherwise a false is returned *)


    var
	found: boolean;
	temptr: userp;

    begin
	found := false;
	temptr := head;

	while (temptr <> nil) and not found do 
	    if temptr^.login = lookfor then begin
		hisrec := temptr^;
		found := true
	    end else 
		temptr := temptr^.next;

	Search := found
    end; { Search }


    procedure newUser;

    (* if the person in not in the linked list, add him *)


    const
	male = 'm';
	female = 'f';
	inc = 1;

    var
	ch: char;
	node: userp;



    begin
	writeln(output, 'To use the Date-A-Base you will have to answer a');
	writeln(output, 'personal questionaire. Your answers to all the');
	writeln(output, 'questions will available for anyone registered');
	writeln(output, 'in the Date-A-Base to look at.');
	writeln(output);
	writeln(output, 'Do you want to continue? ');
	continue := yesNo;
	if continue then begin
	    repeat
		writeln(output);
		writeln(output, 'What sex are you? m or f');
		readln(input, ch)
	    until (ch = male) or (ch = female);
	    static.sex := ch;
	    with static do begin
		timeson := inc
	    end;

(*	    laston := wallclock   *)
	    printques(static.answers);
	    writeln(output);
	    writeln(output, 'What password do you want to use?');
	    writeln(output, 'IMPORTANT: Make this different than');
	    writeln(output, 'your login password.');
	    readstring(static.passwd);
	    new(node);
	    node^ := static;
	    node^.next := head;
	    head := node
	end
    end; { newUser }




    procedure oldUser;

    (* the person is already registered. Just get his data. *)


    const


	inc = 1;
    var
	password: string;
	temptr: userp;
	found: boolean;


    begin
	repeat
	    writeln(output);
	    writeln(output, 'What is your password?');
	    write(output, '? ');
	    readstring(password);
	    if password <> static.passwd then 
		writeln(output, 'Sorry, thats not right!')
	until password = static.passwd;
	with static do begin
	    timeson := timeson + inc
	end;

(*	    laston := wallclock   *)
	temptr := head;
	found := false;
	while (temptr <> nil) and not found do 
	    if temptr^.login = static.login then begin
		static.next := temptr^.next;
		temptr^ := static;
		found := true
	    end else 
		temptr := temptr^.next

    end; { oldUser }



    procedure initialize;

    (* This procedure reads in the current file with all registered
       users into a linked list. *)


    var
	node: userp;
	name: string;

    begin
	head := nil;
	reset(database);
	while not eof(database) do begin
	    new(node);
	    read(database, node^);
	    node^.next := head;
	    head := node
	end; (* while *)
	writeln(output);
	writeln(output);
	writeln(output, '                 The');
	writeln(output, '            Date-A-Base');
	writeln(output);
	writeln(output);
	writeln(output, '  The computerized dating service.');
	writeln(output);
	writeln(output);
	writeln(output);
	writeln(output, 'What is your login name?');
	write(output, '? ');
	continue := true;
	readstring(name);
	static.login := name;
	if not Search(name, static) then 
	    newUser
	else 
	    oldUser


    end; { initialize }

    procedure savedata;

    (* save the linked list in the file database *)


    var
	pointer: userp;


    begin
	rewrite(database);
	pointer := head;
	if pointer <> nil then 
	    while pointer^.next <> nil do begin
		write(database, pointer^);
		pointer := pointer^.next
	    end;
	write(database, pointer^)

    end; { savedata }

    procedure answer;

    (* answer the questionaire again *)


    var
	check: boolean;
	temptr: userp;
	found: boolean;

    begin
	writeln(output);
	writeln(output, 'Are you sure you want to answer all the');
	writeln(output, 'questions again?');
	check := yesNo;
	if check then 
	    printques(static.answers);
	temptr := head;
	found := false;
	while (temptr <> nil) and not found do 
	    if temptr^.login = static.login then begin
		static.next := temptr^.next;
		temptr^ := static;
		found := true
	    end else 
		temptr := temptr^.next

    end; { answer }

    procedure brouse;

    (* give a quick scan of someone else's questionaire. the data for
       the brouse is in bbase. Data looks like:
    
    		  the topic
    		  the maximum answer
    		  answer
    		    .
    		    .
    		    .
    
    		    *)


    const
(*	clicks = 86400;	  *)
	(* number of seconds in a day *)
	low = 'a';
	field = 3;
	zero = 0;
	marker = 15;

    var
	who: string;
	index: char;
	ch: char;
	max: char;
	i: integer;
	j: integer;
(*	time: integer;    *)
	rec: usertype;

    begin
	writeln(output, 'Whose questionare do you want to brouse?');
	write(output, '? ');
	readstring(who);
	if Search(who, rec) then begin

	    i := ONE;
	    j := ONE;
	    reset(bbase);
	    writeln(output);
	    write(output, 'Name: ');
	    writeln(output, rec.login);
	    write(output, 'Used the Date-A-Base ');
	    write(output, rec.timeson: field);
	    if rec.timeson = ONE then 
		writeln(output, ' time. ')
	    else 
		writeln(output, ' times. ');

	    write(output, 'Last used the Date-A-Base: ');
	    (*    time := wallclock - rec.laston;
	    		    time := time div clicks;
	    		    if time = zero then 
	    			writeln(output, 'today.');
	    		    if time = ONE then 
	    			writeln(output, 'yesterday.');
	    		    if time > ONE then begin
	    			write(output, time: field);
	    			writeln(output, ' days ago.')
	    		    end;  *)

	    writeln(output);
	    while not eof(bbase) do begin
		while not eoln(bbase) do begin
		    read(bbase, ch);
		    write(output, ch)
		end;
		readln(bbase);
		readln(bbase, max);
		for index := low to max do begin
		    if index = rec.answers[i] then begin
			while not eoln(bbase) do begin
			    read(bbase, ch);
			    write(output, ch)
			end;
			writeln(output);
			readln(bbase)
		    end else 
			readln(bbase)
		end;
		if j = marker then begin
		    repeat
			writeln(output);
			writeln(output, 'Continue? ')
		    until yesNo;
		    j := zero;
		    writeln(output)
		end;
		j := j + ONE;
		i := i + ONE
	    end
	end else 
	    writeln(output, 'Sorry that person is not registered!');

	repeat
	    writeln(output);
	    writeln(output, 'Return to the menu? ')
	until yesNo
    end; { brouse }

    procedure delete;

    (* delete a person from the linked list *)

    var
	found: boolean;
	pointer: userp;
	previous: userp;

    begin
	found := false;
	writeln(output, 'Are you sure you want to delete yourself?');
	if yesNo then begin
	    pointer := head;
	    previous := head;
	    if pointer^.login = static.login then begin
		head := pointer^.next;
		dispose(pointer)
	    end else  begin
		pointer := pointer^.next;
		    while (not found) and (pointer <> nil) do 
			if pointer^.login = static.login then begin
			    previous^.next := pointer^.next;
			    dispose(pointer);
			    found := true
			end else begin
			    previous := previous^.next;
			    pointer := pointer^.next
	end
	end
    end
    end; { delete }





    procedure match;

    (* find a match between 2 people. scans the whole linked list
       and reports all matches greater than the amount entered. *)


    const
	loginfield = 47;
	perfield = 5;
	dplaces = 1;
	namefield = 33;
	low = 9;
	high = 100;


    var
	pointer: userp;
	percent: integer;
	per: real;
	found: boolean;


    begin
	pointer := head;
	writeln(output);
	writeln(output, 'What is the lowest percent match that');
	writeln(output, 'you want to see? ');
	repeat
	    write(output, ' (10 - 99) ');

	    readint(percent)
	until (percent > low) and (percent < high);


	writeln(output);
	write(output, '%': perfield);
	writeln(output, 'name': namefield);
	writeln(output, '----------------------------------------------------');

	found := false;
	if pointer <> nil then 
	    while pointer <> nil do begin
		per := cstrings(static.answers, pointer^.answers);
		if (per >= percent) and (static.sex <> pointer^.sex) then begin
		    found := true;
		    writeln(output);
		    write(output, per: perfield: dplaces);
		    write(output, '%');
		    writeln(output, pointer^.login: loginfield)
		end;
		pointer := pointer^.next
	    end;
	if not found then begin
	    writeln(output);
	    writeln(output, 'Sorry, no matches found today. Try again later.')
	end;
	repeat
	    writeln(output);
	    writeln(output);
	    writeln(output, 'Are you ready to continue?')
	until yesNo

    end; { match }


    procedure bye;

    begin
	writeln(output);
	writeln(output, 'Thank you for using the Date-A-Base');
	writeln(output, 'Hope to hear from you again soon.');
	writeln(output);
	writeln(output);
	writeln(output);
	writeln(output);
	writeln(output);
	writeln(output,'(c) 1987 Thomas M. Johnson');
	writeln(output)
    end; { bye }


    procedure menu;

    (* The procedure menu is the programs main menu. It prints the
       commands and executes the proper subroutine based on the users
       choice.                                                  *)


    const

	lastchoice = 'e';
    var
	choice: char;

    begin
	repeat
	    writeln(output);
	    writeln(output);
	    writeln(output, '                           Menu');
	    writeln(output, '                           ----');
	    writeln(output);
	    writeln(output, '                 [a]                  answer questionare');
	    writeln(output, '                 [b]                  brouse questionare');
	    writeln(output, '                 [c]                  make a match');
	    writeln(output, '                 [d]                  delete your questionare');
	    writeln(output);
	    writeln(output, '                 [e]                  quit');

	    choice := getanswer(lastchoice);

	    case choice of
		'a':
		    answer;
		'b':
		    brouse;
		'c':
		    match;
		'd':
		    delete;
		'e':
		    writeln(output)
	    end
	until choice = lastchoice

    end; { menu }

begin
    initialize;
    if continue then begin
	menu;
	savedata
    end;
    bye
end. { date }
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦e6bf68ce5⟧ TextFile

Derivation

TextFile
