[Back to COMM SWAG index] [Back to Main SWAG index] [Original]
unit dosfax;
(* UNIT DosFax: Faxen unter DOS *)
(* Erstellt von:
Stefan Cordes
Am Kockshof 24
40882 Ratingen
02102 895 816
Fax: 02561-91371-7324
e-mail: 100331.3700@Compuserve.com
www: http://ourworld.compuserve.com/homepages/Cordes/ *)
interface
Procedure InitModem(comNr:Word;TelNr:String);
Procedure Dial(tp:char;nr:String);
Procedure Sendline(hstr:string);
procedure EndPage;
implementation
uses dos,crt;
const ModemPort:Word=0;
wartetick=40;
Procedure Sendchar(c:char);
var reg:registers;
begin
repeat
reg.ax := $300;
reg.dx := ModemPort;
intr($14,reg);
until (reg.ah and $20)<>0;
repeat
reg.ah := $1;
reg.al := ord(c);
reg.dx := ModemPort;
intr($14,reg);
until (reg.ah and $80)=0;
end;
function Getchar:char;
var reg:registers;
begin
reg.ax := $200;
reg.dx := ModemPort;
intr($14,reg);
GetChar := chr(reg.al);
(* highvideo; write(chr(reg.al)); lowvideo;
if reg.al = 13 then writeln; *)
end;
function charavail:Boolean;
var reg:registers;
begin
reg.ax := $300;
reg.dx := ModemPort;
intr($14,reg);
charavail := (reg.ah and $1)=1;
end;
Procedure SendStr(s:String);
var i1:Word;
begin
delline;
write(s);
delay(50);
for i1 := 1 to length(s) do
begin
sendchar(s[i1]);
end;
end;
var tick:longint absolute $40:$6c;
function GetString:String;
var hstr:String;
ende:Boolean;
endzeit:longint;
c:char;
begin
hstr := '';
endzeit := tick+40;
ende := false;
repeat
if charavail then
begin
c := getchar;
endzeit := tick+40;
if (c=#13) and (hstr<>'') then ende := true;
if c>=#32 then hstr := hstr+c;
end;
if endzeit<tick then ende := true;
until ende;
getstring := hstr;
end;
Procedure Timeout;
begin
writeln('Modem timeout');
delay(1000);
sendstr('+++');
delay(1000);
sendstr('ATH'+#13);
halt(10);
end;
Procedure InitModem(comNr:Word;TelNr:String);
var reg:registers;
endzeit:Longint;
hstr:String;
begin
Writeln('Init Com',comNr);
ModemPort := ComNr-1;
reg.ah := 0;
reg.al := $80+$40+$20+3; (* Baud = 9600, 8n1 *)
reg.dx := ModemPort;
intr($14,reg);
sendstr('AT&FE0'+#13);
endzeit:=tick+WarteTick;
repeat
repeat
if endzeit<tick then Timeout;
until charavail;
hstr := getstring;
until pos('OK',hstr)>0;
sendstr('AT+FCLASS=2'+#13);
endzeit:=tick+WarteTick;
repeat
repeat
if endzeit<tick then Timeout;
until charavail;
hstr := getstring;
until pos('OK',hstr)>0;
sendstr('AT+FLID="'+TelNr+'"'+#13);
endzeit:=tick+WarteTick;
repeat
repeat
if endzeit<tick then Timeout;
until charavail;
hstr := getstring;
until pos('OK',hstr)>0;
sendstr('AT+FDCC=0,3,0,2'+#13);
endzeit:=tick+WarteTick;
repeat
repeat
if endzeit<tick then Timeout;
until charavail;
hstr := getstring;
until pos('OK',hstr)>0;
end;
Procedure Dial(tp:char;nr:String);
var endzeit:Longint;
hstr:String;
begin
tp := upcase(tp);
if (tp<>'T') and (tp<>'P') then tp := 'P';
sendstr('ATD'+tp+nr+#13);
endzeit:=tick+60*18;
repeat
repeat
if endzeit<tick then Timeout;
until charavail;
hstr := getstring;
until pos('OK',hstr)>0;
sendstr('AT+FDT'+#13);
endzeit:=tick+30*18;
repeat
repeat
if endzeit<tick then Timeout;
until charavail;
hstr := getstring;
until pos('CONNECT',hstr)>0;
end;
procedure EndPage;
var endzeit:longint;
hstr:string;
begin
sendstr(#16+#3);
endzeit:=tick+WarteTick;
repeat
repeat
if endzeit<tick then Timeout;
until charavail;
hstr := getstring;
until pos('OK',hstr)>0;
sendstr('AT+FET=2'+#13);
endzeit:=tick+30*18;
repeat
repeat
if endzeit<tick then Timeout;
until charavail;
hstr := getstring;
until pos('OK',hstr)>0;
end;
const TerminatingWhiteCodes:
array[0..63] of array[1..2] of Byte=(
(* 00110101 *) ( 53, 8), (* 0 *)
(* 000111 *) ( 7, 6), (* 1 *)
(* 0111 *) ( 7, 4), (* 2 *)
(* 1000 *) ( 8, 4), (* 3 *)
(* 1011 *) ( 11, 4), (* 4 *)
(* 1100 *) ( 12, 4), (* 5 *)
(* 1110 *) ( 14, 4), (* 6 *)
(* 1111 *) ( 15, 4), (* 7 *)
(* 10011 *) ( 19, 5), (* 8 *)
(* 10100 *) ( 20, 5), (* 9 *)
(* 00111 *) ( 7, 5), (* 10 *)
(* 01000 *) ( 8, 5), (* 11 *)
(* 001000 *) ( 8, 6), (* 12 *)
(* 000011 *) ( 3, 6), (* 13 *)
(* 110100 *) ( 52, 6), (* 14 *)
(* 110101 *) ( 53, 6), (* 15 *)
(* 101010 *) ( 42, 6), (* 16 *)
(* 101011 *) ( 43, 6), (* 17 *)
(* 0100111 *) ( 39, 7), (* 18 *)
(* 0001100 *) ( 12, 7), (* 19 *)
(* 0001000 *) ( 8, 7), (* 20 *)
(* 0010111 *) ( 23, 7), (* 21 *)
(* 0000011 *) ( 3, 7), (* 22 *)
(* 0000100 *) ( 4, 7), (* 23 *)
(* 0101000 *) ( 40, 7), (* 24 *)
(* 0101011 *) ( 43, 7), (* 25 *)
(* 0010011 *) ( 19, 7), (* 26 *)
(* 0100100 *) ( 36, 7), (* 27 *)
(* 0011000 *) ( 24, 7), (* 28 *)
(* 00000010 *) ( 2, 8), (* 29 *)
(* 00000011 *) ( 3, 8), (* 30 *)
(* 00011010 *) ( 26, 8), (* 31 *)
(* 00011011 *) ( 27, 8), (* 32 *)
(* 00010010 *) ( 18, 8), (* 33 *)
(* 00010011 *) ( 19, 8), (* 34 *)
(* 00010100 *) ( 20, 8), (* 35 *)
(* 00010101 *) ( 21, 8), (* 36 *)
(* 00010110 *) ( 22, 8), (* 37 *)
(* 00010111 *) ( 23, 8), (* 38 *)
(* 00101000 *) ( 40, 8), (* 39 *)
(* 00101001 *) ( 41, 8), (* 40 *)
(* 00101010 *) ( 42, 8), (* 41 *)
(* 00101011 *) ( 43, 8), (* 42 *)
(* 00101100 *) ( 44, 8), (* 43 *)
(* 00101101 *) ( 45, 8), (* 44 *)
(* 00000100 *) ( 4, 8), (* 45 *)
(* 00000101 *) ( 5, 8), (* 46 *)
(* 00001010 *) ( 10, 8), (* 47 *)
(* 00001011 *) ( 11, 8), (* 48 *)
(* 01010010 *) ( 82, 8), (* 49 *)
(* 01010011 *) ( 83, 8), (* 50 *)
(* 01010100 *) ( 84, 8), (* 51 *)
(* 01010101 *) ( 85, 8), (* 52 *)
(* 00100100 *) ( 36, 8), (* 53 *)
(* 00100101 *) ( 37, 8), (* 54 *)
(* 01011000 *) ( 88, 8), (* 55 *)
(* 01011001 *) ( 89, 8), (* 56 *)
(* 01011010 *) ( 90, 8), (* 57 *)
(* 01011011 *) ( 91, 8), (* 58 *)
(* 01001010 *) ( 74, 8), (* 59 *)
(* 01001011 *) ( 75, 8), (* 60 *)
(* 00110010 *) ( 50, 8), (* 61 *)
(* 00110011 *) ( 51, 8), (* 62 *)
(* 00110100 *) ( 52, 8));(* 63 *)
MakeUpWhiteCodes:
array[1..27] of array[1..2] of Byte=(
(* 11011 *) ( 27, 5), (* 64 *)
(* 10010 *) ( 18, 5), (* 128 *)
(* 010111 *) ( 23, 6), (* 192 *)
(* 0110111 *) ( 55, 7), (* 256 *)
(* 00110110 *) ( 54, 8), (* 320 *)
(* 00110111 *) ( 55, 8), (* 384 *)
(* 01100100 *) (100, 8), (* 448 *)
(* 01100101 *) (101, 8), (* 512 *)
(* 01101000 *) (104, 8), (* 576 *)
(* 01100111 *) (103, 8), (* 640 *)
(* 011001100 *) (204, 9), (* 704 *)
(* 011001101 *) (205, 9), (* 768 *)
(* 011010010 *) (210, 9), (* 832 *)
(* 011010011 *) (211, 9), (* 896 *)
(* 011010100 *) (212, 9), (* 960 *)
(* 011010101 *) (213, 9), (* 1024 *)
(* 011010110 *) (214, 9), (* 1088 *)
(* 011010111 *) (215, 9), (* 1152 *)
(* 011011000 *) (216, 9), (* 1216 *)
(* 011011001 *) (217, 9), (* 1280 *)
(* 011011010 *) (218, 9), (* 1344 *)
(* 011011011 *) (219, 9), (* 1408 *)
(* 010011000 *) (152, 9), (* 1472 *)
(* 010011001 *) (153, 9), (* 1536 *)
(* 010011010 *) (154, 9), (* 1600 *)
(* 011000 *) ( 24, 6), (* 1664 *)
(* 010011011 *) (155, 9));(* 1728 *)
TerminatingBlackCodes:
array[0..63] of array[1..2] of Byte=(
(* 0000110111 *) ( 55,10), (* 0 *)
(* 010 *) ( 2, 3), (* 1 *)
(* 11 *) ( 3, 2), (* 2 *)
(* 10 *) ( 2, 2), (* 3 *)
(* 011 *) ( 3, 3), (* 4 *)
(* 0011 *) ( 3, 4), (* 5 *)
(* 0010 *) ( 2, 4), (* 6 *)
(* 00011 *) ( 3, 5), (* 7 *)
(* 000101 *) ( 5, 6), (* 8 *)
(* 000100 *) ( 4, 6), (* 9 *)
(* 0000100 *) ( 4, 7), (* 10 *)
(* 0000101 *) ( 5, 7), (* 11 *)
(* 0000111 *) ( 7, 7), (* 12 *)
(* 00000100 *) ( 4, 8), (* 13 *)
(* 00000111 *) ( 7, 8), (* 14 *)
(* 000011000 *) ( 24, 9), (* 15 *)
(* 0000010111 *) ( 23,10), (* 16 *)
(* 0000011000 *) ( 24,10), (* 17 *)
(* 0000001000 *) ( 8,10), (* 18 *)
(* 00001100111 *) (103,11), (* 19 *)
(* 00001101000 *) (104,11), (* 20 *)
(* 00001101100 *) (108,11), (* 21 *)
(* 00000110111 *) ( 55,11), (* 22 *)
(* 00000101000 *) ( 40,11), (* 23 *)
(* 00000010111 *) ( 23,11), (* 24 *)
(* 00000011000 *) ( 24,11), (* 25 *)
(* 000011001010 *) (202,12), (* 26 *)
(* 000011001011 *) (203,12), (* 27 *)
(* 000011001100 *) (204,12), (* 28 *)
(* 000011001101 *) (205,12), (* 29 *)
(* 000001101000 *) (104,12), (* 30 *)
(* 000001101001 *) (105,12), (* 31 *)
(* 000001101010 *) (106,12), (* 32 *)
(* 000001101011 *) (107,12), (* 33 *)
(* 000011010010 *) (210,12), (* 34 *)
(* 000011010011 *) (211,12), (* 35 *)
(* 000011010100 *) (212,12), (* 36 *)
(* 000011010101 *) (213,12), (* 37 *)
(* 000011010110 *) (214,12), (* 38 *)
(* 000011010111 *) (215,12), (* 39 *)
(* 000001101100 *) (108,12), (* 40 *)
(* 000001101101 *) (109,12), (* 41 *)
(* 000011011010 *) (218,12), (* 42 *)
(* 000011011011 *) (219,12), (* 43 *)
(* 000001010100 *) ( 84,12), (* 44 *)
(* 000001010101 *) ( 85,12), (* 45 *)
(* 000001010110 *) ( 86,12), (* 46 *)
(* 000001010111 *) ( 87,12), (* 47 *)
(* 000001100100 *) (100,12), (* 48 *)
(* 000001100101 *) (101,12), (* 49 *)
(* 000001010010 *) ( 82,12), (* 50 *)
(* 000001010011 *) ( 83,12), (* 51 *)
(* 000000100100 *) ( 36,12), (* 52 *)
(* 000000110111 *) ( 55,12), (* 53 *)
(* 000000111000 *) ( 56,12), (* 54 *)
(* 000000100111 *) ( 39,12), (* 55 *)
(* 000000101000 *) ( 40,12), (* 56 *)
(* 000001011000 *) ( 88,12), (* 57 *)
(* 000001011001 *) ( 89,12), (* 58 *)
(* 000000101011 *) ( 43,12), (* 59 *)
(* 000000101100 *) ( 44,12), (* 60 *)
(* 000001011010 *) ( 90,12), (* 61 *)
(* 000001100110 *) (102,12), (* 62 *)
(* 000001100111 *) (103,12));(* 63 *)
MakeUpBlackCodes:
array[1..27] of array[1..2] of Byte=(
(* 0000001111 *) ( 15,10), (* 64 *)
(* 000011001000 *) (200,12), (* 128 *)
(* 000011001001 *) (201,12), (* 192 *)
(* 000001011011 *) ( 91,12), (* 256 *)
(* 000000110011 *) ( 51,12), (* 320 *)
(* 000000110100 *) ( 52,12), (* 384 *)
(* 000000110101 *) ( 53,12), (* 448 *)
(* 0000001101100 *) (108,13), (* 512 *)
(* 0000001101101 *) (109,13), (* 576 *)
(* 0000001001010 *) ( 74,13), (* 640 *)
(* 0000001001011 *) ( 75,13), (* 704 *)
(* 0000001001100 *) ( 76,13), (* 768 *)
(* 0000001001101 *) ( 77,13), (* 832 *)
(* 0000001110010 *) (114,13), (* 896 *)
(* 0000001110011 *) (115,13), (* 960 *)
(* 0000001110100 *) (116,13), (* 1024 *)
(* 0000001110101 *) (117,13), (* 1088 *)
(* 0000001110110 *) (118,13), (* 1152 *)
(* 0000001110111 *) (119,13), (* 1216 *)
(* 0000001010010 *) ( 82,13), (* 1280 *)
(* 0000001010011 *) ( 83,13), (* 1344 *)
(* 0000001010100 *) ( 84,13), (* 1408 *)
(* 0000001010101 *) ( 85,13), (* 1472 *)
(* 0000001011010 *) ( 90,13), (* 1536 *)
(* 0000001011011 *) ( 91,13), (* 1600 *)
(* 0000001100100 *) (100,13), (* 1664 *)
(* 0000001100101 *) (101,13));(* 1728 *)
Procedure Sendline(hstr:string);
var
faxrow:Array[1..1000] of Byte;
faxbit:Word; (* Aktuelles Bit in Faxzeile *)
faxmask:Word;
Procedure AddBits(bits,laenge:Word);
var mask:Word;
begin
mask := 1;
while laenge>1 do
begin
mask := mask*2;
dec(laenge);
end;
while mask>0 do
begin
faxmask := faxmask*2;
if (faxmask = 0) or (faxmask=$100) then
begin
faxmask := $1;
inc(faxbit);
end;
if (bits and mask)<>0 then
begin
faxrow[faxbit] := faxrow[faxbit] or faxmask;
end;
mask := mask div 2;
end;
end;
procedure AddWhitetoFax(anz:Word);
begin
if anz>=64 then
begin (* Startup Char *)
AddBits(MakeUpWhiteCodes[anz div 64,1],MakeUpWhiteCodes[anz div 64,2]);
anz := anz mod 64;
end;
AddBits(TerminatingWhiteCodes[anz,1],TerminatingWhiteCodes[anz,2]);
end;
procedure AddBlacktoFax(anz:Word);
var bits:word;
laenge:Byte;
mask:Word;
begin
if anz>=64 then
begin (* Startup Char *)
AddBits(MakeUpBlackCodes[anz div 64,1],MakeUpBlackCodes[anz div 64,2]);
anz := anz mod 64;
end;
AddBits(TerminatingBlackCodes[anz,1],TerminatingBlackCodes[anz,2]);
end;
procedure SendEol;
begin
if faxbit<20 then faxbit := 20;
inc(faxbit,4);
faxrow[faxbit] := $80;
end;
var
white,black,sw:Word;
iswhite:boolean;
mat:array[1..80,1..16] of byte;
reg:registers;
i1,zl,bit,bitmehrfach:Word;
begin
while length(hstr)>80 do
begin
sendline(copy(hstr,1,80));
delete(hstr,1,80);
hstr := ' '+hstr;
end;
writeln(hstr);
reg.ax := $1130;
reg.bh := $06; (* 06h ROM 8x16 font (MCGA, VGA) *)
intr($10,reg);
fillchar(faxrow,sizeof(faxrow),0);
fillchar(mat,sizeof(mat),0);
for i1 := 1 to length(hstr) do
begin
move(ptr(reg.es,reg.bp+ord(hstr[i1])*16)^,mat[i1],16);
end;
(* Matrix in Faxzeile konvertieren *)
bitMehrfach := 1;
for zl := 1 to 16 do
begin
iswhite := true;
white := 30;
black := 0;
i1 := 1;
bit := $80;
faxbit := 0;
faxmask := 0;
while i1<=length(hstr) do
begin
if (mat[i1,zl] and bit)=0 then
begin
(* Weiá *)
if iswhite then inc(white)
else
begin (* Schwarz abschlieáen *)
AddBlackToFax(black);
inc(sw,black);
iswhite := true;
white := 1;
end;
end
else
begin
(* Schwarz *)
if not iswhite then inc(black)
else
begin (* Weiá abschlieáen *)
AddWhiteToFax(white);
inc(sw,white);
iswhite := false;
black := 1;
end;
end;
if bitmehrfach>0 then dec(bitmehrfach)
else
begin
bit := bit div 2;
bitMehrfach := 1;
end;
if bit=0 then
begin
inc(i1);
bit := $80;
end;
end;
if not iswhite then
begin
AddBlackToFax(1);
inc(sw);
end;
if sw<1728 then
begin
AddWhiteToFax(1728-sw);
end;
SendEol;
sw := 0;
(* Faxrow zum Modem senden *)
for i1 := 1 to faxbit do
begin
if faxrow[i1]=16 then
begin
sendchar(chr(faxrow[i1]));
end;
sendchar(chr(faxrow[i1]));
end;
delay(40);
fillchar(faxrow,sizeof(faxrow),0);
if charavail then getstring;
end;
end;
end.
{ -------------------- DEMO PROGRAM -------------------- }
uses dosfax,crt;
var txt:text;
hstr:string;
i1:Word;
begin
clrscr;
InitModem(1,'02561/91371-7324');
Dial('T','02561913717324'); (* 474168 *)
assign(txt,'text.txt');
reset(txt);
while not eof(txt) do
begin
readln(txt,hstr);
Sendline(hstr);
end;
for i1 := 1 to 12 do
begin
Sendline('');
end;
EndPage;
close(txt);
end.
[Back to COMM SWAG index] [Back to Main SWAG index] [Original]