{-----------------------------------------------------------}
{
{    Programa para testes de multipla escolha falados
{
{    Autor: Jose' Antonio Borges
{
{    Em 22/01/97
{
{-----------------------------------------------------------}

program questvox;
uses
    dvcrt, dvwin, winprocs;

const versao = '1.1a';

var nomeArq: string;
    arq: text;

type
    strNome = string[8];

    plistaLinhas = ^listaLinhas;
    listaLinhas = record
        linha: string[80];
        proxLinha: pListaLinhas;
    end;

type
    tquestao = record
        som: strNome;
        texto: plistaLinhas;
        nitems: integer;
        item: array [1..10] of plistaLinhas;
        valorItem: array [1..10] of integer;
        resposta: char;
    end;

var
    somTitulo: strNome;
    textoTitulo: plistaLinhas;

    nomePessoa: string;
    questao: array [1..200] of tquestao;
    nquestoes: integer;
    s: string;

    ninterAval: integer;
    somAval: strNome;
    textoAval: plistaLinhas;

    limAval: array [0..200] of integer;
    somCritAval: array [0..200] of strNome;
    critAval: array [0..200] of pListaLinhas;
    nota: integer;

{-----------------------------------------------------------}
{                        mensagens
{-----------------------------------------------------------}

procedure mensagem (m: string);
var i: integer;
begin
     if m = 'QVINIC' then
         begin
             clrscr;
             setWindowText (crtWindow, 'QUESTVOX');
             textBackground (BLUE);
             textColor (YELLOW);
             gotoxy (1, 1);
             writeln (' +----------------------------------------------------------------------------+');
             for i := 2 to 12 do
                 writeln (' |                                                                            |');
             writeln (' +----------------------------------------------------------------------------+');

             gotoxy (33, 4);
             writeln ('Projeto DOSVOX');
             gotoxy (33, 6);
             writeln ('Q U E S T V O X');
             gotoxy (29, 8);
             writeln ('Questionário automático');
             gotoxy (35, 10);
             writeln ('Versão ', versao);
             textBackground (BLACK);
             textColor (LIGHTGRAY);
         end
     else
     if m = 'QVERTRAD' then
         writeln ('Erro no diretório do tradutor')
     else
     if m = 'QVQUENOM' then
         writeln ('Informe o nome do arquivo de questões:')
     else
     if m = 'QVDESIS' then
         writeln ('Desistiu...')
     else
     if m = 'QVARQNAO' then
          writeln ('Arquivo de questões não existe')
     else
     if m = 'QVFIM' then
          write ('Fim do programa')
     else
     if m = 'QVINSTRU' then
          begin
              writeln ('Responda cada pergunda com uma letra');
              writeln ('Use PAGE UP ou PAGE DOWN para voltar páginas');
              write ('Aperte ESC para terminar as respostas');
          end
     else
     if m = 'QVARQVAZ' then
          write ('Arquivo de questões vazio')
     else
     if m = 'QVLONGA' then
          writeln ('Erro: linhas muito grandes no arquivo (mais de 79 letras)')
     else
     if m = 'QVQUESTA' then
          write ('Questão ')
     else
     if m = 'QVINCORR' then
          writeln (' incorretamente especificada')
     else
     if m = 'QVRESINC' then
          writeln (' com uma resposta inválida.')
     else
     if m = 'QVAVALER' then
          writeln ('Intervalos de avaliação inválidos')
     else
     if m = 'QVERTIT' then
          writeln ('T¡tulo incorretamente especificado')
     else
     if m = 'QVNQUEST' then
          write ('        Número de questões: ')
     else
     if m = 'QVERRARQ' then
          write ('Erro de escrita no arquivo ! ')
     else
     if m = 'QVLETINV' then
          write ('Letra inválida! ')
     else
     if m = 'QVCNFFIM' then
          write ('Confirma término de suas respostas ? ')
     else
     if m = 'QVJAULT' then
          write ('Esta foi a última pergunta, ESC termina')
     else
     if m = 'QVJAPRIM' then
          write ('Estamos na primeira pergunta')
     else
     if m = 'QVQUESTN' then
          write ('Questão ')
     else
     if m = 'QVNOME' then
          writeln ('Informe seu nome')
     ;

     sintSom (m);
end;

{-----------------------------------------------------------}
{          sintetiza um som do diretorio de trabalho
{-----------------------------------------------------------}

procedure sintSomArq (s: string);
var salva: string;
begin
(*
    salva := diretAplic;
    getdir (0, diretAplic);
    if diretAplic [length(diretAplic)] <> '\' then
        diretAplic := diretAplic + '\';
    diretAplic := salva;
*)
end;

{-----------------------------------------------------------}
{                        finaliza
{-----------------------------------------------------------}

procedure finaliza;
begin
    delay (1000);
    gotoxy (12, 23);
    mensagem ('QVFIM');
    delay (1000);
    textMode (CO80);
    sintFim;
    doneWincrt;
end;

{-----------------------------------------------------------}
{            insere uma cadeia na lista de textos
{-----------------------------------------------------------}

procedure insLisTexto (var texto: pListaLinhas; s: string);
var
    p, q: plistaLinhas;
begin
    new (q);
    with q^ do
        begin
            linha := s;
            proxLinha := NIL;
        end;

    if texto = NIL then
        texto := q
    else
        begin
            p := texto;
            while p^.proxLinha <> NIL do
                p := p^.proxLinha;
            p^.proxLinha := q;
        end;

    if length (s) > 79 then
        begin
            mensagem ('QVLONGA');
            finaliza;
        end;
end;

{-----------------------------------------------------------}
{                pega um texto do arquivo
{-----------------------------------------------------------}

function pegaTexto (var nomeSom: strnome; var texto: plistaLinhas): boolean;
var i: integer;
begin
    pegaTexto := true;

    while s = '' do
        begin
            if eof (arq) then
                begin
                     mensagem ('QVARQVAZ');
                     finaliza;
                end
            else
                readln (arq, s);
        end;

    nomeSom := '';
    texto := NIL;

    if s[1] = '[' then
        begin
            s := s + ']';
            i := 2;
            while s[i] <> ']' do
                begin
                    nomeSom := nomeSom + s[i];
                    i := i + 1;
                end;

            if eof (arq) then
                s := ''
            else
                readln (arq, s);
        end;

    if s = '' then
        begin
            pegaTexto := false;
            exit;
        end;

    repeat
        while (s <> '') and (s[1] = ' ') do
            delete (s, 1, 1);
        insLisTexto (texto, s);
        if eof (arq) then
            s := ''
        else
            readln (arq, s);
    until (s = '') or (s[1] <> ' ');
end;

{-----------------------------------------------------------}
{                pega uma resposta do arquivo
{-----------------------------------------------------------}

procedure pegaUmaResposta (nr: integer;
                  var texto: plistaLinhas; var valor: integer);
var num: string;
    n, erro: integer;
label errou;

begin
    { ja leu s }

    if upcase(s[1]) <> chr (nr-1+ord('A')) then
        begin
errou:
            mensagem ('QVQUESTA');
            sintWriteInt (nQuestoes);
            mensagem ('QVRESINC');
            finaliza;
        end;

    repeat
        delete (s, 1, 1);
    until (s = '') or (s[1] <> ' ');

    num := '';
    while (s <> '') and (s[1] in ['0'..'9']) do
        begin
            num := num + s[1];
            delete (s, 1, 1);
        end;

    if num = '' then goto errou;
    val (num, valor, erro);
    if erro <> 0 then goto errou;

    texto := NIL;
    repeat
        while (s <> '') and (s[1] = ' ') do
            delete (s, 1, 1);
        if s <> '' then
            insLisTexto (texto, s);
        if eof (arq) then
            s := ''
        else
            readln (arq, s);
    until (s = '') or (s[1] <> ' ');
end;

{-----------------------------------------------------------}
{              carrega as questoes na memoria
{-----------------------------------------------------------}

procedure carregaQuestoes;
var
    i: integer;
begin
    nquestoes := 0;
    s := '';
    if not pegaTexto (somTitulo, textoTitulo) then
        begin
            mensagem ('QVERTIT');
            finaliza;

        end;

    while not eof (arq) do
        begin
            nquestoes := nquestoes + 1;

            with questao[nquestoes] do
                begin
                    for i := 1 to 10 do
                        begin
                            item [i] := NIL;
                            valorItem [i] := 0;
                        end;
                    resposta := ' ';

                    if not pegaTexto (som, texto) then
                        begin
                            mensagem ('QVQUESTAO');
                            sintWriteInt (nQuestoes);
                            mensagem ('QVINCORR');
                            finaliza;
                        end;

                    if texto^.linha = '*' then
                        begin
                            nquestoes := nquestoes - 1;
                            exit;
                        end;

                    nitems := 0;
                    while s <> '' do
                        begin
                            nitems := nitems + 1;
                            pegaUmaResposta (nitems,
                                        item[nitems], valorItem[nitems]);
                        end;
                end;
        end;
end;

{-----------------------------------------------------------}
{               carrega atributos da avaliacao
{-----------------------------------------------------------}

procedure carregaAvaliacao;
var erro: integer;
    i, j, temp: integer;
    tempc: pointer;
    temps: string;
begin
    s := '';
    nInterAval := 0;

    if not pegaTexto (somAval, textoAval) then
        exit;

    repeat
            readln (arq, s);
            ninterAval := ninterAval + 1;
            val (s, limAval[ninterAval], erro);
            if erro <> 0 then
                begin
                    mensagem ('QVAVALER');
                    finaliza;
                end;

            s := '';
            if not pegaTexto (somCritAval [ninterAval],
                              critAval [ninterAval]) then
                begin
                    mensagem ('QUAVALER');
                    finaliza;
                end;
    until eof (arq);
    close (arq);

    for i := 1 to ninterAval-1 do
        for j := i+1 to ninterAval do
             if limAval [i] > limAval [j] then
                 begin
                      temp := limAval [i];
                      limAval [i] := limAval [j];
                      limAval [j] := temp;

                      temps := somCritAval [i];
                      somCritAval [i] := somCritAval [j];
                      somCritAval [j] := temps;

                      tempc := critAval [i];
                      critAval [i] := critAval [j];
                      critAval [j] := tempc;
                 end;
end;

{-----------------------------------------------------------}
{                   sintetiza um texto
{-----------------------------------------------------------}

procedure falaTexto (p: plistaLinhas);
begin
    while p <> NIL do
        begin
            sintetiza (p^.linha);
            p := p^.proxLinha;
        end;
end;

{-----------------------------------------------------------}
{                   centra uma linha
{-----------------------------------------------------------}

procedure centraLinha (y: integer; s: string);
begin
    gotoxy ((80-length(s)) div 2, y);
    write (s);
end;

{-----------------------------------------------------------}
{         apresenta um texto centrada verticalmente
{-----------------------------------------------------------}

procedure textoCentrado (var y: integer; p: plistaLinhas);
begin
    while p <> NIL do
        begin
            gotoxy (1, 1);
            delLine;
            centraLinha (y, p^.linha);
            y := y + 1;
            p := p^.proxLinha;
        end;
end;

{-----------------------------------------------------------}
{         apresenta um texto alinhado a esquerda
{-----------------------------------------------------------}

procedure textoEsquerda (var y: integer; p: plistaLinhas);
begin
    while p <> NIL do
        begin
            writeln (p^.linha);
            y := y + 1;
            p := p^.proxLinha;
        end;
end;

{-----------------------------------------------------------}
{                  apresenta uma questao
{-----------------------------------------------------------}

procedure apresentaQuestao (qAtual: integer);
var i, y: integer;
    c: char;
begin
    while keypressed do c := readkey;

    clrscr;
    gotoxy (1, 1);
    mensagem ('QVQUESTN');
    sintWriteInt (qAtual);

    with questao [qatual] do
        begin
            writeln;
            y := 3;
            textoEsquerda (y, texto);
            writeln;
            for i := 1 to nItems do
                begin
                    write (chr (ord ('A')-1+i), ' - ');
                    textoEsquerda (y, item[i]);
                end;

            gotoxy (20, wherey+1);

            if som = '' then
                begin
                    falaTexto (texto);
                    for i := 1 to nItems do
                          begin
                              delay (200);
                              sintCarac (chr (ord ('A')-1+i));
                              delay (200);
                              falaTexto (item[i]);
                          end;
                 end
            else
                sintSomArq (som);
        end;

end;

{-----------------------------------------------------------}
{                   aplica as questoes
{-----------------------------------------------------------}

procedure aplicaQuestoes;
var
    processando: boolean;
    c, ultLetra: char;
    qAtual: integer;


    procedure trataControles;
    var c: char;
    begin
        c := readkey;
        case c of
            PGUP,
            CIMA: if qatual > 1 then
                      qAtual := qAtual - 1
                  else
                      begin
                          gotoxy (1, 25);
                          clreol;
                          mensagem ('QVJAPRIM');
                          qatual := 1;
                      end;

            PGDN,
            BAIX: if qatual < nQuestoes then
                      qAtual := qAtual + 1
                  else
                      begin
                          gotoxy (1, 25);
                          clreol;
                          mensagem ('QVJAULT');
                          qatual := nQuestoes;
                      end;

            HOME, CTLPGUP: qAtual := 1;
            TEND, CTLPGDN: qAtual := nQuestoes;
        end;

    end;


begin
    clrscr;

    gotoxy (1, 13);
    mensagem ('QVNQUEST');
    sintWriteInt (nQuestoes);

    processando := true;
    
    qatual := 1;
    while processando do
        begin
            delay (1000);
            sintBip; sintBip;

            if qatual < 1 then
                 begin
                     gotoxy (1, 25);
                     clreol;
                     mensagem ('QVJAPRIM');
                 end
            else
            if qatual > nQuestoes then
                 begin
                     gotoxy (1, 25);
                     clreol;
                     mensagem ('QVJAULT');
                 end
            else
                apresentaQuestao (qAtual);

            with questao [qatual] do
                begin
                    c := upcase(readkey);
                    ultLetra := chr (nitems-1 + ord('A'));

                    if c = #$0 then
                        trataControles
                    else
                    if c = #$1b then
                        begin
                            gotoxy (1, 25);
                            clreol;
                            mensagem ('QVCNFFIM');
                            c := upcase(readkey);
                            sintCarac (c);
                            if c = 'S' then
                                processando := false;
                        end
                    else
                    if (qatual > 0) and (qatual <= nquestoes) and
                       (c in ['A'..ultLetra]) then
                        begin
                            write (c);
                            sintCarac (c);
                            resposta := c;
                            qatual := qatual + 1;
                        end
                    else
                        begin
                            gotoxy (1, 25);
                            clreol;
                            mensagem ('QVLETINV');
                        end;
                end;
        end;
end;

{-----------------------------------------------------------}
{              registra as respostas num arquivo
{-----------------------------------------------------------}

procedure registraRespostas;
var arq: text;
    i: integer;
begin
    assign (arq, 'RESPOSTA.TXT');
    {$I-} reset (arq); {$I+}
    if ioresult <> 0 then
        begin
            {$I-}  rewrite (arq);  {$I+}
            if ioresult <> 0 then
                begin
                    mensagem ('QVERRARQ');
                    finaliza;
                end;
        end
    else
        begin
            close (arq);
            {$I-}  append (arq);  {$I+}
            if ioresult <> 0 then
                begin
                    mensagem ('QVERRARQ');
                    finaliza;
                end;
        end;

    writeln (arq, nomePessoa);
    for i := 1 to nquestoes do
        with questao [i] do
            write (arq, resposta);
    writeln (arq);
    writeln (arq, nota);

    close (arq);
end;

{-----------------------------------------------------------}
{                   mostra a avaliacao
{-----------------------------------------------------------}

procedure avalia;
var y, i: integer;
    p, q: plistaLinhas;
    s: strNome;
label achou;
begin
    nota := 0;
    for i := 1 to nquestoes do
        with questao [i] do
            if resposta <> ' ' then
                nota := nota + valorItem [ord(resposta) and $f];

    p := textoAval;
    q := NIL;

    s := '';
    for i := ninterAval downto 1 do
        if nota >= limAval [i] then
            begin
                q := critAval [i];
                s := somCritAval [i];
                goto achou;
            end;

achou:
    clrscr;
    y := 12;
    textoCentrado (y, p);
    textoCentrado (y, q);

    if somAval = '' then
        falaTexto (textoAval)
    else
        sintSomArq (somAval);

    delay (200);

    if s = '' then
        falaTexto (q)
    else
        sintSomArq (s);
end;

{-----------------------------------------------------------}
{                    escreve tela inicial
{-----------------------------------------------------------}

procedure telaInicial;
var y: integer;
begin
    clrscr;
    y := 12;
    textoCentrado (y, textoTitulo);
    if somTitulo <> '' then
        sintSomArq (somTitulo)
    else
        falaTexto (textoTitulo);
end;

{-----------------------------------------------------------}
{                 inicializa e abre arquivo
{-----------------------------------------------------------}

procedure inicializa;
begin
    sintinic (0, sintAmbiente ('QUESTVOX', 'DIRQUESTVOX'));
    sintFalaPont := false;

    mensagem ('QVINIC');
    sintSoletra (versao);

    if paramcount <> 0 then
        begin
            delay (2000);
            nomeArq := paramstr(1);
        end
    else
        begin
            gotoxy (1, 15);
            mensagem ('QVQUENOM');
            sintReadln (nomeArq);
            if nomeArq = '' then
                begin
                    gotoxy (1, 20);
                    mensagem ('QVDESIS');
                    finaliza;
                end;

        end;

    assign (arq, nomeArq);
    {$I-} reset (arq); {$I+}
    if ioresult <> 0 then
        begin
            assign (arq, nomeArq+'.QUE');
            {$I-} reset (arq); {$I+}
            if ioresult <> 0 then
                begin
                    writeln;
                    mensagem ('QVARQNAO');
                    delay (2000);
                    finaliza;
                end;
        end;

end;

{-----------------------------------------------------------}
{                 pergunta o nome do usuario
{-----------------------------------------------------------}

procedure perguntaNome;
begin
    gotoxy (1, 22);
    mensagem ('QVNOME');
    sintReadln (nomePessoa);
    if nomePessoa = '' then
        begin
            gotoxy (1, 23);
            mensagem ('QVDESIS');
            finaliza;
        end;

end;

{-----------------------------------------------------------}
{                       programa principal
{-----------------------------------------------------------}

var y: integer;
begin
    inicializa;

    carregaQuestoes;
    carregaAvaliacao;

    telaInicial;
    perguntaNome;

    aplicaQuestoes;
    avalia;
    registraRespostas;

    finaliza;
end.
