{--------------------------------------------------------}
{
{    Programa de impressao braille
{
{    Autor: Jose' Antonio Borges
{
{    Em 1994/95
{
{--------------------------------------------------------}

program BraiVox;
uses
    crt, dos;

const
    MAIUSCULAS: set of char = ['A'..'Z', #$c0..#$df];   { ANSI apenas }
    MINUSCULAS: set of char = ['a'..'z', #$e0..#$ff];

    VOGAIS     = ['A', 'E', 'I', 'O', 'U', 'a', 'e', 'i', 'o', 'u'];
    CONSOANTES = ['B', 'C', 'D', 'F', 'G', {'H', }'J', 'L', 'M',
                  'N', 'P', 'Q', 'R', 'S', 'T', 'V', 'X', 'Z',
                  'b', 'c', 'd', 'f', 'g', {'h', }'j', 'l', 'm',
                  'n', 'p', 'q', 'r', 's', 't', 'v', 'x', 'z' ];

    MAIUSCBRL     = #$0f;  {shift in}

    ABREASPASBRL  = '{';
    FECHAASPASBRL = '}';
    PONTOBRL      = '.';
    RETICBRL      = '''''''';
    VIRGDECBRL    = ',';
    PONTODECBRL   = '''';
    PERCENTBRL    = '}j';

    IGUALBRL      = '==';
    MAIORBRL      = '-:';
    MENORBRL      = ':-';
    DIVIDIDO      = '//';

    AZINHO        = 'a';
    OZINHO        = 'o';
    PARAGRAFO     = 'ss';

var
    arq, arqsai: text;
    nomearq, nomesai: string;
    texto, textoCnv, titulo: string;

    soFrente, abre_aspas: boolean;
    autoJunta: boolean;
    maxcarac, maxlin, npag, nlin, numinic,
    paginic, pagfinal,
    ncopias: integer;
    ambDosvox: string;
    imprMatricial, frenteVerso, paginando: boolean;
    sobraAnterior: string;
    centrando, comTitulo: boolean;

    tabBraille: array [#0..#255] of byte;
    tabPrinter: array [#0..#255] of byte;

{--------------------------------------------------------}
{                 fala uma mensagem
{--------------------------------------------------------}

procedure mensagem (s: string);
begin
    if s = 'BRCNFERR' then
        writeln ('Arquivo de configuracao inexistente, programa cancelado')
    else
    if s = 'BRERRLIN' then
        write   ('Erro no arquivo de configuracao na linha ')
    else
    if s = 'BRERRBRL' then
        write   ('Erro no arquivo BRAILLE.AMB perto da linha ')
    else
    if s = 'BRTRUNC' then
        write  ('Linha truncada: ')
    else
    if s = 'BRDEL' then
        write (#08, ' ', #08)
    else
    if s = 'BRDESIS' then
        writeln  ('--- desistiu ---')
    else
    if s = 'BRLPPAG' then
        write ('Quantas linhas por pagina (0 para nao paginar) ? ')
    else
    if s = 'BRCPLIN' then
        write ('Quantos caracteres por linha ? ')
    else
    if s = 'BRNUMINI' then
        write ('Numero a imprimir na pagina inicial (sugiro 1): ')
    else
    if s = 'BRNCOP' then
        write ('Quantas copias (sugiro 1) ? ')
    else
    if s = 'BRPAGINI' then
        write ('Pagina inicial (sugiro 1): ')
    else
    if s = 'BRPAGFIN' then
        write ('Pagina final (sugiro 9999): ')
    else
    if s = 'BRINTRO' then
        writeln ('Programa de impressao Braille - v 1.1')
    else
    if s = 'BRNOMARQ' then
        write ('Digite o nome do arquivo a imprimir: ')
    else
    if s = 'BRARQNAO' then
        writeln ('Arquivo nao foi achado')
    else
    if s = 'BRARQIMP' then
        write ('Digite o nome do arquivo de impressao (sugiro PRN): ')
    else
    if s = 'BRERRCRI' then
        writeln ('Erro ao criar arquivo.  Programa cancelado.')
    else
    if s = 'BRCOMTIT' then
        write ('Deseja titulos e numeracao ? ')
    else
    if s = 'BRTIT' then
        writeln ('Informe o titulo: ')
    else
    if s = 'BRTIPIMP' then
        write ('Tipo de impressora: M - Matricial   B - Braille: ')
    else
    if s = 'BRPADRAO' then
        write ('Assumo valores padrao (s/n) ? ')
    else
    if s = 'BRFIMCOP' then
        write ('Fim de impressao da copia ')
    else
    if s = 'BRFIMTRA' then
        writeln ('Fim de trabalho')
    else
    if s = 'BRFREVER' then
        write ('Frente e verso (s/n) ? ')

    else
    if s = 'BRAUTOJU' then
        write ('Deseja auto-reformatacao para Braille (s/n) ? ')

    else
        begin
            writeln;
            writeln ('-------------------------------');
            writeln ('--- mensagem errada: ', s, '---');
            writeln ('-------------------------------');
            writeln;
        end;
end;

{--------------------------------------------------------}
{              assume parametros default
{--------------------------------------------------------}

procedure assumeParamDefaults;
begin
    if imprMatricial then
        begin
            maxlin := 60 div 4;
            maxcarac := 80 div 2;
        end
    else
        begin
            maxlin := 28;
            maxcarac := 37;
        end;

    numinic := 1;
    ncopias := 1;
    paginic := 1;
    pagfinal := 9999;
    titulo := '';
    frenteVerso := true;
    paginando := true;
    autoJunta := true;
    comTitulo := true;
end;

{--------------------------------------------------------}
{                 pede parametros de impressao
{--------------------------------------------------------}

procedure pedeParametros;
var resp, c2: char;
    m: integer;
begin
    paginando := true;

    titulo := '';

    mensagem ('BRAUTOJU');
    readln (resp);
    autoJunta := upcase (resp) = 'S';

    mensagem ('BRCOMTIT');
    readln (resp);
    comTitulo := upcase (resp) = 'S';

    mensagem ('BRLPPAG');
    m := 0;
    readln (m);
    if m <= 0 then
        begin
            paginando := false;
            maxlin := 32766;
        end
    else
        maxlin := m;

    mensagem ('BRCPLIN');
    m := 0;
    readln (m);
    if m > 0 then
        maxcarac := m;

    if paginando then
        begin
            numinic := 1;
            mensagem ('BRNUMINI');
            readln (numinic);
            if numinic <= 0 then
                numinic := 1;
        end;

    ncopias := 1;
    mensagem ('BRNCOP');
    readln (ncopias);
    if ncopias <= 0 then
        ncopias := 1;

    mensagem ('BRPAGINI');
    readln (paginic);
    if paginic <= 0 then
        paginic := 1;

    mensagem ('BRPAGFIN');
    readln (pagfinal);
    if pagfinal <= 0 then
        pagfinal := 1;
end;

{--------------------------------------------------------}
{            processa arquivo de configuracao
{--------------------------------------------------------}

function pegaParam (nome: string; nomearq: string): string;
var
    arq: text;
    linha: string;

begin
    pegaParam := '';

    assign (arq, nomearq);
    {$I-} reset (arq); {$I+}
    if ioresult <> 0 then
        exit;

    while not eof (arq) do
        begin
            readln (arq, linha);
            if pos (nome+'=', linha) = 1 then
                pegaParam := copy (linha, length (nome)+2,
                                   length (linha)-length (nome)-1);
        end;

    close (arq);
end;

{--------------------------------------------------------}
{                  converte lido hexa
{--------------------------------------------------------}

function cnvhexa (c1, c2: char): byte;
var v1, v2, v: integer;
begin
    c1 := upcase (c1);
    c2 := upcase (c2);

    if c1 >= 'A' then
        v1 := ord (c1) - ord ('A') + 10
    else
        v1 := ord (c1) - ord ('0');

    if c2 >= 'A' then
        v2 := ord (c2) - ord ('A') + 10
    else
        v2 := ord (c2) - ord ('0');

    cnvhexa := (v1 shl 4) or v2;
end;

{--------------------------------------------------------}
{         carrega configuracao da impressora
{--------------------------------------------------------}

procedure carregaConfigImpr;
var
    arqConfig: text;
    ambBraivox: string;
    linha, i: integer;
    c1, c2, x, p1, p2: char;
    s: string;

label proxima, erro;

begin
    for i := 0 to 255 do
        tabPrinter [chr(i)] := i;

    ambBraivox := pegaParam ('AMBBRAIVOX', ambDosvox);
    if ambBraivox = '' then
        exit;

    assign (arqConfig, ambBraivox);
    {$I-} reset (arqConfig); {$I+}

    if ioresult <> 0 then
        begin
            mensagem ('BRCNFERR');
            halt;
        end;

    while not eof (arqConfig) do
        begin
            linha := linha + 1;
            {$I-} readln (arqConfig, s); {$I+}
            if (s = '') or (s[1] = '*') then
                goto proxima;

            i := cnvhexa (s[1], s[2]);
            tabPrinter [chr(i)] := cnvHexa (s[4], s[5]);

            if (ioresult <> 0) or (s[3] <> '=') or (i < 0) or (i > 255) then
                goto erro;
proxima:
        end;

    close (arqConfig);

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

    if false then   { erro de processamento }
        begin
erro:
            close (arqConfig);
            mensagem ('BRERRLIN');
            writeln (linha);

            halt;
        end;
end;

{--------------------------------------------------------}
{          pega defaults da codificacao Braille
{--------------------------------------------------------}

procedure carregaConfigMatricial;
var
    arqConfig: text;
    ambBraille, s: string;
    linha, l, i, valor: integer;
    bit: byte;

label proxima, erro;

begin
    for i := 0 to 255 do
        tabBraille [chr(i)] := 0;

    ambBraille := pegaParam ('AMBBRAILLE', ambDosvox);
    if ambBraille = '' then
        ambBraille := copy (getenv('AMBDOSVOX'), 1, 2) +
                   '\DOSVOX\BRAILLE.AMB';

    assign (arqConfig, ambBraille);
    {$I-} reset (arqConfig); {$I+}

    if ioresult <> 0 then
        begin
            mensagem ('BRCNFERR');
        end;

    linha := 0;
    while not eof (arqConfig) do
        begin
            {$I-} readln (arqConfig, s); {$I+}
            linha := linha + 1;
            if (s = '') or (s[1] = '*') then goto proxima;

            l := cnvhexa (s[1], s[2]);
            delete (s, 1, 2);
            while (s <> '') and ((s[1] = '=') or (s[1] = ' ')) do
                delete (s, 1, 1);

            if length (s) <> 6 then goto erro;

            valor := 0;
            for i := 1 to 6 do
                begin
                    if s[i] = '0' then bit := 0
                    else
                    if s[i] = '1' then bit := 1
                    else
                        goto erro;

                    valor := valor + (bit shl (i-1));
                end;

            tabBraille [chr(l)] := valor;
proxima:
        end;

        exit;

erro:
    close (arqConfig);
    mensagem ('BRERRLIN');
    writeln ((linha-1) * 4);

    halt;
end;

{--------------------------------------------------------}
{          inicializacao e abertura de arquivos
{--------------------------------------------------------}

procedure inicializa;
var resp, c2: char;
label fim;
begin
    ambdosvox := getenv('AMBDOSVOX');
    if ambDosvox = '' then
        ambDosvox := 'c:\dosvox\dosvox.amb';


    writeln;
    writeln ('-------------------------------------');
    mensagem ('BRINTRO');
    writeln ('-------------------------------------');
    writeln;

    if paramcount = 1 then
        nomearq := paramstr(1)
    else
        begin
            mensagem ('BRNOMARQ');
            readln (nomearq);
            if nomearq = '' then
                goto fim;
        end;

    assign (arq, nomearq);
    {$i-}  reset (arq);  {$i+}
    if ioresult <> 0 then
        begin
            mensagem ('BRARQNAO');
            goto fim;
        end;

    imprMatricial := false;

    assumeParamDefaults;

    if imprMatricial then
        carregaConfigMatricial
    else
        carregaConfigImpr;

    mensagem ('BRARQIMP');
    readln (nomesai);
    if nomesai = '' then
        nomesai := 'PRN';

    assign (arqsai, nomesai);
    {$i-}  rewrite(arqsai);  {$i+}
    if ioresult <> 0 then
        begin
            mensagem ('BRERRCRI');
            goto fim;
        end;

    mensagem ('BRFREVER');
    readln (resp);
    frenteVerso := upcase (resp) = 'S';

    mensagem ('BRPADRAO');
    readln (resp);
    if (resp <> '') and (upcase (resp) = 'N') then
        pedeParametros;

    sobraAnterior := '';
    exit;

fim:
    halt;
end;

{--------------------------------------------------------}
{             converte uma letra para minuscula
{--------------------------------------------------------}

function convMinusc (c: char): char;
begin
    if c in ['A'..'Z'] then 
        c := chr (ord(c) + $20)
    else

    if c in [#$c0..#$df] then
        c := chr (ord(c) + $20);

    convMinusc := c;
end;

{--------------------------------------------------------}
{                  da Saida
{--------------------------------------------------------}

procedure escreveSaida (texto: string);
var i, linha: integer;
    bit: byte;
    s: string;
begin
    if npag < paginic then exit;
    if npag > pagfinal then exit;

    if imprMatricial then
        begin
            write (arqsai, #$1b, 'A', #$8);  { impressao comprimida }
            for linha := 0 to 2 do
                begin
                    s := '';
                    for i := 1 to length (texto) do
                        begin
                            bit := 1 shl linha;
                            if (tabBraille [texto[i]] and bit) <> 0 then
                                s := s + '.'
                            else
                                s := s + ' ';

                            bit := 8 shl linha;
                            if (tabBraille [texto[i]] and bit) <> 0 then
                                s := s + '.'
                            else
                                s := s + ' ';
                        end;

                    s := s + '                                        ';
                    s := s + '                                        ';

                    for i := (maxcarac * 2) downto 1 do
                        write (arqsai, s[i]);
                    write (arqsai, #$0d);
                    for i := (maxcarac * 2) downto 1 do
                        write (arqsai, s[i]);
                    writeln (arqsai);
                end;

            write (arqsai, #$1b, 'A', #$12);  { impressao normal }
            writeln (arqsai);
        end
    else
        begin
            for i := 1 to length (texto) do
                texto[i] := chr (tabPrinter [texto[i]]);
            writeln (arqsai, texto);
        end;
end;

{--------------------------------------------------------}
{             converte uma linha para Braille
{--------------------------------------------------------}

function convBraille (texto: string): string;
var
    s: string;
    posl: integer;
    c: char;
    parteInic: string;

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

    procedure convNumero;
    begin
        s := s + '#';

        while (posl <= length(texto)) and
              (texto[posl] in ['0'..'9', '.', ',', '-', '/']) do
             begin
                 case texto[posl] of
                    ',': s := s + VIRGDECBRL;
                    '.': s := s + PONTODECBRL;
                    '-': s := s + '-';
                    '/': s := s + '-';
                 else
                     s := s + texto[posl];
                 end;
                 posl := posl + 1;
             end;
    end;

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

    procedure convPalavra;
    begin
        repeat
            s := s + texto[posl];
            posl := posl + 1;
        until (posl > length(texto)) or
                      not (texto[posl] in MAIUSCULAS);
    end;

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

    procedure convPalavraMaiusc;    { nao trata o caso MMmM }
    begin
        if (posl >= length(texto)) or
                   not (texto [posl+1] in MAIUSCULAS) then
            begin
                c := convMinusc (texto[posl]);
                s := s + MAIUSCBRL + c;
                posl := posl + 1;
            end
        else
            begin
                s := s + MAIUSCBRL + MAIUSCBRL;
                repeat
                    c := convMinusc (texto[posl]);
                    s := s + c;
                    posl := posl + 1;
                until (posl > length(texto)) or
                              not (texto[posl] in MAIUSCULAS);
            end;
    end;


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

    procedure convPonto;
    begin
        if (length (texto) >= posl+2) and
           (texto [posl+1] = '.') and
           (texto [posl+2] = '.') then
            begin
                s := s + RETICBRL;
                posl := posl + 3;
            end
        else
            begin
                s := s + PONTOBRL;
                posl := posl + 1;
            end;
    end;

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

    procedure convAspas;
    begin
        if abre_aspas then
            begin
                s := s + ABREASPASBRL;
                abre_aspas := false;
            end
        else
            begin
                s := s + FECHAASPASBRL;
                abre_aspas := true;
            end;

        posl := posl + 1;
    end;

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

    procedure convCarac;
    begin
        case texto [posl] of
            '=': s := s + IGUALBRL;
            '%': s := s + PERCENTBRL;
        else
            s := s + texto[posl];
        end;

        posl := posl + 1;
    end;

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

begin
    s := '';

    if (texto <> '') then
       if (texto[1] = ' ') and (texto[2] <> ' ') then
           delete (texto, 1, 1);

    posl := 1;
    while posl <= length (texto) do
        begin
            if texto [posl] in MINUSCULAS then
                convPalavra
            else

            if texto[posl] in MAIUSCULAS then
                convPalavraMaiusc
            else

            if texto[posl] in ['0'..'9'] then
                convNumero
            else

            if texto[posl] = '.' then
                convPonto
            else

            if texto[posl] = '"' then
                convAspas
            else

                convCarac;
        end;

    convBraille := s;
end;

{--------------------------------------------------------}
{                     escreve o titulo
{--------------------------------------------------------}

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

const brancos = '                                                  ';

begin
    npag := npag + 1;

    if npag > pagFinal then
            exit;

    if not paginando then exit;

    if npag > paginic then
        write (arqsai, #$0c);

    nlin := 1;

    if not comTitulo then exit;

    salva := texto;

    texto := titulo;
    tituloCnv := convBraille (texto);

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

    if odd(npag) or (not frenteVerso) then
        begin
             str (npag-paginic+numinic:4, np);
             texto := np;
             textoCnv := convBraille (texto);
             escreveSaida (tituloCnv+textoCnv);
        end
    else
        begin
            str (npag-paginic+numinic, np);
            np := np + '   ';
            np := copy (np, 1, 4);
            texto := np;
            textoCnv := convBraille (texto);
            escreveSaida (textoCnv+tituloCnv);
        end;


    texto := salva;
end;

{--------------------------------------------------------}
{            divide a linha Braille em duas
{--------------------------------------------------------}

procedure quebraSaida (var texto, parte1: string);
var posic: integer;
    i, aIncluir: integer;
begin
    posic := maxCarac-1;
    while (posic > 10) and (texto[posic-1] <> ' ') and
        not (     { fimsilaba }
          (texto[posic-1] in VOGAIS + ['S', 's', 'N', 'n', 'R', 'r']) and
          (texto[posic] in CONSOANTES) and
          (texto[posic+1] in VOGAIS)
        )  do
               posic := posic - 1;

    parte1 := copy (texto, 1, posic-1);
    if texto[posic-1] <> ' ' then
        parte1 := parte1 + '-'
    else
        while parte1 [length (parte1)] = ' ' do
            delete (parte1, length(parte1), 1);

    texto  := copy (texto, posic, length(texto)-posic+1);
end;

{--------------------------------------------------------}
{                   converte uma linha
{--------------------------------------------------------}

procedure converteLinha (texto: string);
var s, parteInic: string;
    descarrega: boolean;

begin
    descarrega := (texto = '') or (not autoJunta);

    if sobraAnterior <> '' then
        s := sobraAnterior + ' ' + convBraille (texto)
    else
        s := convBraille (texto);

    repeat
        if (nlin = 0) or (nlin = maxlin) then
            escreveTitulo;

        if (length (s) > maxcarac) then
            begin
                quebraSaida (s, parteInic);
                escreveSaida (parteInic);
                nlin := nlin + 1;
            end
        else
            begin
                if descarrega then
                    begin
                        escreveSaida (s);
                        sobraAnterior := '';
                        nlin := nlin + 1;
                    end
                else
                    sobraAnterior := s;

                s := '';
            end;

    until s = '';
end;

{--------------------------------------------------------}
{    remove brancos ao final e so' deixa dois no inicio
{--------------------------------------------------------}

procedure compactaLinha (var texto: string);
begin
    while (texto <> '') and (texto [length (texto)] = ' ') do
        delete (texto, length(texto), 1);

    while (length (texto) > 2) and
          (texto [1] = ' ') and (texto [2] = ' ') and (texto [3] = ' ') do
            delete (texto, 1, 1);
end;

{--------------------------------------------------------}
{                   corpo da impressao
{--------------------------------------------------------}

procedure impressao;
label fim, ok, naoImprime;
var i, aIncluir: integer;

begin
    nlin := 0;
    npag := 0;
    texto := '';
    abre_aspas := true;

    while not eof (arq) do
        begin
            if npag > pagFinal then goto fim;

            texto := '*';      { para detetar paragrafo }
            readln (arq, texto);

            centrando := autoJunta and
                  (length (texto) > 10) and
                  (copy (texto, 1, 10) = '          ');

            compactaLinha (texto);

            if (texto = '<p>') or (texto = '<P>') then
                begin
                    if autoJunta then
                        converteLinha ('');
                    escreveTitulo;
                end
            else
                begin
                    if centrando and (sobraAnterior <> '') then
                         converteLinha ('')
                    else
                    if autoJunta and (sobraAnterior <> '') then
                        if (texto = '') or (texto[1] = ' ') then { paragrafo }
                             converteLinha ('');
                    converteLinha (texto);

                    if centrando then
                        begin
                            aIncluir := (maxCarac - length (sobraAnterior)) div 2;
                            for i := 3 to aIncluir do
                                 sobraAnterior := ' ' + sobraAnterior;
                            converteLinha ('');
                        end;
                end;
        end;

    if (npag <= pagFinal) and (sobraAnterior <> '') then
        converteLinha ('');

fim:
    if nlin <> 0 then
        write (arqsai, #$0c);

    if odd(npag) and (frenteVerso) then
        begin
            writeln (arqsai);
            write (arqsai, #$0c);
        end;
end;

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

var i: integer;
    s: string;
begin
    inicializa;

    for i := 1 to ncopias do
        begin
            impressao;
            close (arq);

            mensagem ('BRFIMCOP');
            if ncopias <> 1 then
                writeln (i);
            writeln;

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

    close (arqsai);
    mensagem ('BRFIMTRA');

end.
