{--------------------------------------------------------}
{
{   Programa de controle da impressora Thiel
{
{   Autor: Jose' Antonio Borges
{
{   Em 26/04/95
{
{--------------------------------------------------------}
program portathiel;
uses crt, printer;

const
    BAXINTER = 1;
    BAXSEMINTER = 2;
    BETA = 3;
    BLAZIE = 4;
    CLICHEINTER = 5;
    CLICHESEMINTER = 6;

    MAIUSCULAS: set of char = [
        'A'..'Z',

        '', 'Ç', '·', '¶', '', 'µ',
        'Ò', '', 'Ô',
        'Ö', 'Ø', 'Þ',
        '', 'å', 'â', 'à',
        'é', '', 'ë',
        ''
    ];

var
    arq, arqsai: text;
    nomearq, nomesai: string;
    texto, textoCnv, titulo: string;
    soFrente, comNumero, abre_aspas: boolean;
    maxcarac, maxlin, npag, nlin, numinic,
    paginic, pagfinal,
    linOrig, pol, ncopias: integer;
    tipoImpressao: integer;
    copiatirada: integer;
    brancosIniciais: string;
    frenteVerso: boolean;

{--------------------------------------------------------}

function convMinusc (c: char): char;
begin
    if c in ['A'..'Z'] then 
        c := chr (ord(c) + $20)
    else
        if c in MAIUSCULAS then
            case c of
         '',   'Ç': c := #$3e;
                '·': c := #$24;
                '¶': c := #$2a;
         '',   'µ': c := #$28;

                'Ò': c := #$3c;
                '': c := #$3d;
                'Ô': c := #$21;

                'Ö': c := #$2f;
                'Ø': c := #$5d;
                'Þ': c := #$25;

         '',   'å': c := #$5b;
                'â': c := #$3f;
                'à': c := #$2b;

                'é': c := #$29;
                '': c := #$5c;
                'ë': c := #$3a;

                '': c := #$26;
            end;
    convMinusc := c;
end;

{--------------------------------------------------------}

procedure converte;
var s: string;
    i: integer;
    c: char;
begin
    s := '';

    i := 1;
    while i <= length (texto) do
        begin
            if texto[i] in ['a'..'z'] then
                s := s + texto[i]
            else
            if texto[i] in ['0'..'9'] then
                begin
                    s := s + #$23;
                    while (i <= length(texto)) and
                          (texto[i] in ['0'..'9', '.', ',', '-', '/']) do
                         begin
                             case texto[i] of
                                '1': s := s + 'a';
                                '2': s := s + 'b';
                                '3': s := s + 'c';
                                '4': s := s + 'd';
                                '5': s := s + 'e';
                                '6': s := s + 'f';
                                '7': s := s + 'g';
                                '8': s := s + 'h';
                                '9': s := s + 'i';
                                '0': s := s + 'j';
                                ',': s := s + '1';
                                '.': if (i <> length (texto)) and (texto[i+1] in ['0'..'9']) then
                                         s := s + ''''
                                     else
                                         s := s + #$34;

                                '-': s := s + #$2d;
                                '/': s := s + '/';
                             end;
                             i := i + 1;
                         end;
                    i := i - 1;
                end
            else
            if texto[i] in MAIUSCULAS then
                begin
                    if (i = length(texto)) or
                       not  (texto [i+1] in MAIUSCULAS) then
                        begin
                              c := convMinusc (texto[i]);
                              s := s + #$2e + c;
                        end
                    else
                        begin
                            s := s + #$2e + #$2e;
                            repeat
                                c := convMinusc (texto[i]);
                                s := s + c;
                                i := i + 1;
                            until (i > length(texto)) or
                                  not (texto[i] in MAIUSCULAS);
                            i := i - 1;
                        end;
                end
            else

                case texto[i] of
                   {pontuacao}
                        '-': s := s + #$2d;
                       '''': s := s + #$27;
           {grifo}      '_': s := s + #$5f;

                        ',': s := s + #$31;
                        ';': s := s + #$32;
                        ':': s := s + #$33;
                        '=': s := s + #$33+#$33;
                        '+': s := s + #$35;

                        '.': if (texto [i+1] = '.') and
                                (texto[i+2] = '.') then
                                 begin
                                     s := s + #$27 + #$27 + #$27;
                                     i := i + 2;
                                 end
                             else
                                 s := s + #$34;

                        '?': s := s + #$35;
                        '$': s := s + #$34;
                        '!': s := s + #$36;
                        '(': s := s + #$37;
                        ')': s := s + #$37;
                        '&': s := s + #$2c;
                        '[': s := s + #$5e;
                        ']': s := s + #$2e;
                        '\': s := s + #$3b;
                        '%': s := s + #$30+'j';

                        '|': s := s + #$22;


                        '=': s := s + #$33+#$33;
                        '>': s := s + ':c';
                        '<': s := s + ':-';

                        '{': s := s + #$38;
                        '}': s := s + #$30;

                        '"': if abre_aspas then
                                   begin
                                       s := s + #$38;
                                       abre_aspas := false;
                                   end
                             else
                                   begin
                                       s := s + #$30;
                                       abre_aspas := true;
                                   end;

                        '*': s := s + #$39;

                   {letras acentuadas}
                   '', 'Æ': s := s + #$3e;
                        '': s := s + #$24;
                        '': s := s + #$2a;
                        ' ': s := s + #$28;

                        '': s := s + #$3c;
                        '': s := s + #$3d;
                        '': s := s + #$21;

                        '¡': s := s + #$2f;
                        '': s := s + #$5d;
                        '': s := s + #$25;

                        '', 'ä': s := s + #$5b;
                        '': s := s + #$3f;
                        '¢': s := s + #$2b;

                        '£': s := s + #$29;
                        '': s := s + #$5c;
                        '': s := s + #$3a;

                        '': s := s + #$26;

                   '', 'Ç': s := s + #$2e + #$3e;
                        '·': s := s + #$2e + #$24;
                        '¶': s := s + #$2e + #$2a;
                   '', 'µ': s := s + #$2e + #$28;


                        'Ò': s := s + #$2e + #$3c;
                        '': s := s + #$2e + #$3d;
                        'Ô': s := s + #$2e + #$21;

                        'Ö': s := s + #$2e + #$2f;
                        'Ø': s := s + #$2e + #$5d;
                        'Þ': s := s + #$2e + #$25;

                   '', 'å': s := s + #$2e + #$5b;
                        '': s := s + #$2e + #$3f;
                        '¢': s := s + #$2e + #$2b;

                        'é': s := s + #$2e + #$29;
                        '': s := s + #$2e + #$5c;
                        'ë': s := s + #$2e + #$3a;

                        '': s := s + #$2e + #$26;

                        '<': s := s + #$3C;
                        '>': s := s + #$3E;

           {grifo}      '_': s := s + #$d4;

                   else
                       s := s + texto [i];
                   end;
            i := i + 1;
        end;

    textoCnv := s;

    if length (textoCnv) > maxcarac then
         begin
             writeln ('Linha original: ', linOrig,
                     ' Pagina ', npag, ', linha ', nlin,
                     ': muito grande, truncada...');
             writeln (#7,textoCnv);
             textoCnv := copy (textoCnv, 1, maxcarac);
         end;
end;

{--------------------------------------------------------}

procedure pedeParametros;
var resp: char;

begin
    write ('Qual o tamanho da p gina em polegadas (11 ou 13) ? ');
    readln (pol);

    write ('Quantas linhas por pagina (30 se 13 pol, 24 se 11 pol): ');
    readln (maxlin);
    write ('Quantos caracteres por linha (',
            maxcarac, ' se folha grande): ');
    readln (maxcarac);

    if titulo = '' then
        begin
            write ('Com numeracao de p gina (s/n) ? ');
            readln (resp);
            if upcase (resp) = 'N' then
                comNumero := false
            else
                begin
                    write ('Numero a imprimir na pagina inicial (sugiro 1): ');
                    readln (numinic);
                end;
        end;

    ncopias := 1;
    if (nomesai = 'PRN')   or (nomesai = 'prn') or
       (nomesai = 'prn:')  or (nomesai = 'PRN:') then
       begin
           write ('Quantas copias ? ');
           readln (ncopias);
       end;

    write ('Pagina inicial: ');
    readln (paginic);
    write ('Pagina final (sugiro 9999): ');
    readln (pagfinal);

end;

{--------------------------------------------------------}

procedure assumeDefaults;
var alinhamento: integer;
    i: integer;
begin
    case tipoImpressao of

    BAXINTER:
        begin
            maxcarac := 42;
            pol := 13;
            maxlin := 30;
            frenteVerso := true;
        end;

    BAXSEMINTER:
        begin
            maxcarac := 42;
            pol := 13;
            maxlin := 30;
            frenteVerso := false;
        end;

    BETA:
        begin
            maxcarac := 42;
            pol := 13;
            maxlin := 30;
            frenteVerso := false;
        end;

    BLAZIE:
        begin
            maxcarac := 34;
            pol := 11;
            maxlin := 24;
            frenteVerso := false;
        end;

    CLICHEINTER:
        begin
            maxcarac := 40;
            pol := 13;
            maxlin := 30;
            frenteVerso := true;
        end;

    CLICHESEMINTER:
        begin
            maxcarac := 40;
            pol := 13;
            maxlin := 30;
            frenteVerso := false;
        end;

    else
        begin
            maxcarac := 40;
            pol := 11;
            maxlin := 30;
            frenteVerso := false;
        end;
    end;

    numinic := 1;
    ncopias := 1;
    paginic := 1;
    pagfinal := 9999;
    comNumero := true;

    write ('Qual o alinhamento de p gina (sugiro 0) ? ');
    readln (alinhamento);
    brancosIniciais := '';
    for i := 1 to alinhamento do
        brancosIniciais := brancosIniciais + ' ';

    maxcarac := maxcarac - alinhamento;
end;

{--------------------------------------------------------}

procedure abrearq;
var resp: char;
begin
    writeln;
    writeln ('-----------------------------------------');
    writeln ('Programa de impresso Braille: InterPoint');
    writeln ('           VersÆo 1.13 de 08/12/98');
    writeln ('-----------------------------------------');
    writeln;
    write ('Digite o nome do arquivo a imprimir: ');
    readln (nomearq);

    assign (arq, nomearq);
    {$i-}  reset (arq);  {$i+}
    if ioresult <> 0 then
        begin
            writeln ('Arquivo no foi achado');
            halt;
        end;

    write ('Digite o nome do arquivo de impresso: ');
    readln (nomesai);
    assign (arqsai, nomesai);
    {$i-}  rewrite(arqsai);  {$i+}

    writeln ('Informe o titulo: ');
    writeln ('---------1---------2---------3---------4---------5');
    readln (titulo);

    writeln ('Escolha: 1 - Bax Interponto,  2 - Bax sem Inter  3 - Beta');
    write   ('         4 - Blazie   5 - Cliche  6 - Cliche sem inter: ');
    readln (tipoImpressao);

    assumeDefaults;

    write ('Assumo configurao padro (s/n) ? ');
    readln (resp);
    if upcase (resp) <> 'S' then
        pedeParametros;

    if tipoImpressao in [BAXINTER, BAXSEMINTER, BETA] then
        begin
            write (arqsai, #$1b, '.', chr (pol+$30));    { configura polegadas }
            write (arqsai, #$1b, '0Z');     { 42 caracteres por linha }
            write (arqsai, #$1b, '1P');     { 31 linhas por pagina }
        end;
end;

{--------------------------------------------------------}

procedure pulaPaginas;
var n, i, npul: longint;
    x: string;
begin
    if comNumero then
        npul := (paginic-1) * (maxlin-1)
    else
        npul := (paginic-1) * maxlin;
    for n := 1 to npul do
        if not eof (arq) then
            begin
                readln (arq, x);
                for i := 1 to length (x) do
                    if x[i] = '"' then
                        abre_aspas := not abre_aspas;
                linOrig := linOrig + 1;
            end;
end;

{--------------------------------------------------------}

procedure escreveTitulo;
var salva, np, tituloCnv: string;
    nbrancos, brAntes, brDepois: integer;

const brancos = '                                                  ';

begin
    npag := npag + 1;

    if (npag > pagFinal) or (npag < pagInic) then
        exit;

    if npag > paginic then
        begin
            write (arqsai, #$0c);
            if tipoImpressao = BAXSEMINTER then
                write (arqsai, #$0c);
        end;

    if comNumero then
        nlin := 1
    else
        begin
            nlin := 0;
            exit;
        end;

    salva := texto;

    texto := titulo;
    converte;
    tituloCnv := textoCnv;

    nbrancos := maxcarac - 5 - length (textoCnv);
    brAntes := nbrancos div 2;
    brDepois := nbrancos - brAntes;
    tituloCnv := copy (brancos, 1, brAntes) + tituloCnv +
                 copy (brancos, 1, brDepois);

    np := '    ';
    if odd(npag) or (not frenteVerso) then
        begin
             if (brancosIniciais <> '') then
                 write (arqsai, brancosIniciais);
             if comNumero and (npag > 0) then 
                 str (npag: 4, np);
             texto := np;
             converte;
             writeln (arqsai, tituloCnv+textoCnv);
        end
    else
        begin
            if comNumero and (npag > 0) then
                begin
                    str (npag, np);
                    np := np + '   ';
                    np := copy (np, 1, 4);
                end;
            texto := np;
            converte;
            writeln (arqsai, textoCnv+tituloCnv);
        end;

    texto := salva;
end;

{--------------------------------------------------------}

procedure impressao;
label fim;
var c: char;
begin
    nlin := 0;
    npag := numinic-1;

    while not eof (arq) do
        begin
            if (nlin = 0) or (nlin = maxlin) then
                 escreveTitulo;

            if npag > pagFinal then
                begin
                    npag := npag - 1;
                    goto fim;
                end;

            if keypressed then
                begin
                    c := readkey;
                    if c = #$1b then
                        begin
                            copiatirada := 9999;
                            goto fim;
                        end;
                end;

            readln (arq, texto);
            linOrig := linOrig + 1;
            while texto [length (texto)] = ' ' do   { elimina brancos finais }
                 texto [0] := chr (ord (texto[0]) - 1);

            nlin := nlin + 1;

            if texto = '<p>' then 
                escreveTitulo
            else
                begin
                    converte;

                    if length (textoCnv) > maxcarac then
                        begin
                            writeln ('Pagina ', npag, ', linha ', nlin, 
                                    ': muito grande, truncada...');
                            writeln (textoCnv);
                            readln;
                            textoCnv := copy (textoCnv, 1, maxcarac);
                        end;

                    if (brancosIniciais <> '') then
                        begin
                            if odd(npag) or (not frenteVerso) then
                                write (arqsai, brancosIniciais);
                        end;

                    writeln (arqsai, textoCnv)
                end;
        end;

fim:
    if nlin <> 0 then
        begin
            write (arqsai, #$0c);
            npag := npag + 1;
        end;
    if not (odd(npag)) and (tipoImpressao = BAXINTER) then
        write (arqsai, #$0c);
end;

{--------------------------------------------------------}

begin
    abreArq;

    copiatirada := 0;
    while copiatirada < ncopias do
        begin
            abre_aspas := true;
            linOrig := 0;
            copiatirada := copiatirada + 1;

            pulaPaginas;
            impressao;
            if copiatirada = 9999 then
                writeln ('Impressao interrompida')
            else
                writeln ('Fim de Impresso da C¢pia ', copiatirada);
            close (arq);

            if copiatirada < ncopias then
                reset (arq);
        end;

    close (arqsai);
    writeln ('Fim de trabalho');
end.
