DataMuseum.dk

top - metrics - download

    Length: 15553 (0x3cc1)
    Types: TextFile
    Names: »date.v2.p«

└─⟦b20c6495f⟧ Bits:30007238 EUUGD18: Wien-båndet, efterår 1987
    └─⟦this⟧ »EUUGD18/General/Dating/date.v2.p« 

TextFile

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

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

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

    file used:
       .date/Questions - holds the questionaire
       .date/database  - all the people registered with the Date-A-Base
			 and their information
       .date/bbase     - data used by the brouse command.
       /tmp/.name      - used to get the login name

    version 2.1 must have getw.h in the same directory. This routine
      allows Pascal to access the C getlogin() function.


(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;
	    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;

#include "getw.h"

    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 clearstring(var tempstring: string);

    const

	blank = ' ';
    var
	i: integer;

    begin
	for i := ONE to STRINGLENGTH do 
	    tempstring[i] := blank
    end; { clearstring }



    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;

    var
	ch: char;
	length: integer;

    begin
	repeat
	    clearstring(tempstring);
	    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, '/usr/u1/john1233/.date/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 test(string1: string; string2: string): boolean;

    (* I was having a lot of trouble converting the Search function from
       version 1 to this version because the strings were coming out
       of the getw.h external procedure 1 character longer than all the
       other strings. So the comparison was always false. This function
       takes the place of that comparison.
       *)

    var
	same: boolean;
	i: integer;
	chset: set of char;


    begin
	i := ONE;
	same := true;
	chset := ['a'..'z', 'A'..'Z', '0'..'9'];

	while (string1[i] in chset) and (string2[i] in chset) and same do begin
	    same := string1[i] = string2[i];
	    i := i + ONE
	end;

	test := same;
    end; { test }




    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 test(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 be 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;
		laston := wallclock
	    end;
	    printques(static.answers);
	    writeln(output);
	    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
	temptr: userp;
	found: boolean;


    begin
	writeln(output);
	with static do begin
	    timeson := timeson + inc;
	    laston := wallclock
	end;
	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. *)


    const

	copymax = 15;
    var
	node: userp;
	name: string;
	i: integer;
	namef: text;

    begin
	head := nil;
	getwh(name);
	reset(database, '/usr/u1/john1233/.date/database');
	reset(namef, '/tmp/.name');
	i := 1;
	while not eof(namef) do begin
	    read(namef, name[i]);
	    i := i + 1
	end;
	while not eof(database) do begin
	    new(node);
	    read(database, node^);
	    node^.next := head;
	    head := node
	end;
	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);
	continue := true;
	for i := ONE to copymax do 
	    static.login[i] := name[i];

	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, '/usr/u1/john1233/.date/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
	low = 'a';
	clicks = 86400;					(* number of seconds in a day *)
	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, '/usr/u1/john1233/.date/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					(* while not eof *)
	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					{else} {else}

	end {if yesNo}
    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 = 0;
	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 }