Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/games/volume2/dating/date.v2.p

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

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

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

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

    version 2.0 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,'.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;
    if string1[i + ONE] <> string2[i + ONE] then
        test := false
    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;

    begin
    head := nil;
    reset(database,'.date/database');
    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;
    clearstring(name);
    getwh(name);
    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,'.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,'.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;

    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 = 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 }