Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/games/volume2/dating/date.v1.p

Text File | 1987-10-26 | 15KB | 718 lines

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

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

             [e-mail]
                  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;

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