program pictextest;

program pictextest;

uses {cb_util,}dos,crt{,mathfunc};

type styp = (right,left);

var aus : text;
ausn,oben,unten,rechts,links,eingabe,ausgabe,
savename,savekomm,unterschrift,labelstr,ueberschrift : string;
unitx,unity, xmax,xmin,ymax,ymin,dx,dy,dxsub,dysub,breite,hoehe,
unitry, rymin,rymax,rdy,rdysub : real;
fertig,rechteachse,xlog,ylog,rylog,xkreuz,ykreuz,rykreuz : boolean;
ydez,xdez,rydez : byte;
ch,sprache : char;
seite : styp;
dos_major_version, dos_minor_version : integer;

(***********************************************************************
Received: by DEARN (Mailer R2.03B) id 8469; Wed, 14 Feb 90 18:27:58 MEZ
Date: Wed, 14 Feb 90 01:19:57 CST
Reply-To: Borland Pascal Discussion Group <PASCAL-L@YALEVM>
Sender: Borland Pascal Discussion Group <PASCAL-L@YALEVM>
From: "John M. Kelsey" <[email protected]>
Subject: Cursor questions
To: "Christian Boettger, TU Braunschweig, FRG" <I2010506@DBSTU1>

I finally got around to looking up the three BIOS interrupst I needed
to call and got a working package to make the cursor vanish, then restore
it to the same kind of cursor it was before. (Otherwise, a program which
uses different cursor-sizes at different times, and uses a generic routine
to set the cursor off and back to the small cursor, may have the cursor
size change every time, say, a window is blown open.) I'll type these two
procedures in here.
*************************************************************************)

Procedure Cursor_Vanish(VAR W : Word);
VAR Regs : Registers;
Begin WITH Regs DO Begin
AH := $03;
BH := $00;
Intr($10,Regs);
W := CX;
AH := $01;
CL := $20;
CH := $20;
Intr($10,Regs);
End End; { End procedure }

Procedure Cursor_Restore(VAR W : Word );
VAR Regs : Registers;
Begin WITH Regs DO Begin
AH := $01;
BH := $00;
CX := W;
Intr($10,Regs);
End End; { End procedure }

(*************************************************************************
These two procedures have to be compiled with the DOS unit available.
(After the Program line, put uses DOS;)

I've tried to be pretty careful typing these in, but I don't even pretend
to be perfect, so if you want to use these procedures, I'd recommend typing
them in, then saving them, then running a program once as a test. (A test
program for these two should be pretty simple.)

Also, regarding the screen saving procedures in _Turbo Pascal, the
Complete Reference_, I've written some routines that implement a simple
stack of saved screens, so that you can simply push the present screen
state, draw your menu, then pop the last screen state off the stack.
If anyone's interested, I should be able to upload the routines from a PC
disk....

--John Kelsey, C445585@UMCVMB
**************************************************************************)

Function Zentriere (meldung : string; var status : boolean) : byte;
{Berechnet X-Position fr zentrierte Ausgabe von MELDUNG mit GotoXY}
var laenge : byte;
begin
laenge := length(meldung);
if ((laenge>=80) or (laenge=0)) then status := false else status := true;
if status then Zentriere := (80-length(meldung)) DIV 2
else Zentriere := 0;
end; {of Zentriere}

procedure Ende (var raus : boolean);
var screen : string;
status : boolean;
antwort : char;

BEGIN
raus := FALSE;
ClrScr;
screen := 'Programm wirklich beenden (j/n) ? ';
GotoXY(Zentriere(screen,status),12); write(screen);
Readln(antwort);
antwort := UpCase(antwort);
IF antwort = 'J' THEN raus := TRUE;
END;

procedure StandBy;
CONST meldung1 = 'Weiter mit beliebiger Taste';
meldung2 = ' ';
var x,y,x_pos : byte;
muell : char;
cursor : word;
status : boolean;
begin
Cursor_Vanish(cursor);
x:=whereX; y:= WhereY;
x_pos := Zentriere(meldung1,status);
GotoXY(x_pos,25);
HighVideo;
write(meldung1);
NormVideo;
repeat until keypressed;
muell := ReadKey;
GotoXY(x_pos,25); write(meldung2);
GotoXY(x,y);
Cursor_Restore(cursor);
end;

(************************************************************************
Received: from CUNYVM by CUNYVM.BITNET (Mailer R2.03B) with BSMTP id 6339; Tue,
13 Feb 90 21:05:12 EST
Received: from cod.nosc.mil by CUNYVM.CUNY.EDU (IBM VM SMTP R1.2.2MX) with TCP;
Tue, 13 Feb 90 21:05:09 EST
Received: by cod.nosc.mil (5.59/1.27)
id AA01529; Tue, 13 Feb 90 18:06:29 PST
Date: Tue, 13 Feb 90 18:06:29 PST
From: [email protected] (Susan Howell)
Message-Id: <[email protected]>
To: ADD.@BOETT
Cc: [email protected]
Subject: Source for supporting unit ERRORCOD

-------

APPENDIX R

SOURCE LISTING FOR UNIT ERRORCOD

***********************************************************************)
(*******************************************************************)
(**** ERRORCOD.PAS ****)
(**** This unit maps MS-DOS error codes returned by the ****)
(**** operating system to strings to give the operator a ****)
(**** human readable response. ****)
(**** ****)
(**** Reference: MS-DOS Version 3 Programmer's Utility Pack ****)
(**** MS-DOS Reference Guide Volume 1 ****)
(**** 1986, pp. 4.86-4.88, 4.254-4.257. ****)
(**** ****)
(**** Developed by Nelson Ard ****)
(**** ****)
(**** Last modificaton Sep 89 ****)
(*******************************************************************)
(*********************
UNIT ErrorCod;

INTERFACE

USES Dos;
*******************)
CONST Error_Code : ARRAY [0..88] OF
string[40] = ('No errors',
'Invalid function code',
'File not found',
'Path not found',
'No file handles left',
'Access denied',
'Invalid handle',
'Memory control blocks destroyed',
'Insufficient memory',
'Invalid memory block address',
'Invalid environment',
'Invalid format',
'Invalid access code',
'Invalid data',
'RESERVED error code',
'Invalid drive',
'Attempt to remove the current directory',
'Not same device',
'No more files',
'Disk is write-protected',
'Bad disk unit',

'Drive not ready',
'Invalid disk command',
'CRC error',
'Invalid length (disk operation)',
'Seek error',
'Not an MS-DOS disk',
'Sector not found',
'Out of paper',
'Write fault',
'Read fault',
'General failure',
'Sharing violation',
'Lock violation',
'Wrong disk',
'FCB unavailable',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'Network request not supported',
'Remote computer not listening',
'Duplicate name on network',
'Network name not found',
'Network busy',
'Network device no longer exists',
'Net BIOS command limit exceeded',
'Network adapter hardware error',
'Incorrect response from network',
'Unexpected network error',
'Incompatible remote adapt',
'Print queue full',
'Queue not full',
'Not enough space for print file',
'Network name was deleted',
'Access denied',
'Network device type incorrect',
'Network name not found',
'Network name limit exceeded',
'Net BIOS session time exceeded',
'Temporarily paused',
'Network request not accepted',

'Print or disk redirection is paused',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'File exits',
'Duplicate File Control Block',
'Cannot make',
'Interrupt 24 failure',
'Out of structures',
'Already assigned',
'Invalid password',
'Invalid parameter',
'Net write fault');

CONST Error_Class : ARRAY [1..12] OF string[40] =
('Out of a resource',
'Temporary situation',
'Permission problem',
'Internal error in system software',
'Hardware failure',
'System software failure',
'Application program error',
'File or item not found',
'File or item of invalid format',
'File or item interlocked',
'Media failure - storage medium',
'Unknown error');

Recommended_Error_Action : ARRAY [1..7] OF String[40] =
('Retry, then prompt user',
'Retry after a pause',
'Reprompt user to reenter',
'Terminate with clean up',
'Terminate immediately',
'Observe only',
'Retry after correcting fault');

Error_Locus : ARRAY [1..5] OF String[40] =
('Unknown',
'Random Access block device',
'Related to a network',
'Related to serial access device',
'Related to RAM');

(************************************************
PROCEDURE Extended_Error_Code (VAR Error_Code : INTEGER;
VAR Error_Class : Byte;
VAR Error_Locus : Byte);

{ Following an error code returned by an MS-DOS function call or
I/O function, this may be called for amplification on the
error }

**********IMPLEMENTATION**********************)

Var index : integer;

PROCEDURE Extended_Error_Code (VAR Error_Code : INTEGER;
VAR Error_Class : Byte;
VAR Error_Locus : Byte);

Var Regs : Registers;

BEGIN
Regs.AH := $59;
Regs.BX := 0;
Intr($21, Regs);
Error_Code := Regs.AX;
Error_Class := Regs.BH;
Error_Locus := Regs.CH;
END;
(*********************
BEGIN
END.
*********************)
(***********************************************************************
-------

Addressees in 'BOETT.ADD' are: I2010506%[email protected]
************************************************************************)

{***************************************************************************}
{ Name : GET_DOS_VERSION }
{ }
{ Purpose : To obtain the version number of DOS. }
{ }
{ Input : none }
{ }
{ Output : dos_major_ver : version of dos }
{ dos_minor_ver : level of dos_major_ver }
{ }
{ Example : DOS 3.1 would yield [dos_major_ver = 3 }
{ dos_minor_ver = 10] }
{***************************************************************************}
procedure get_dos_version(var maj, min : integer);
var regs : registers;
begin
with regs do begin
ah:=$30;
msdos(regs);
maj := al;
min := ah;
end;
end;

procedure GetDOSErrorMessage (code : integer; var message : string);
begin
case code of
0 : message := 'OK';
2 : message := 'Datei nicht gefunden';
3 : message := 'Suchweg nicht gefunden';
5 : message := 'Zugriff verweigert';
6 : message := 'Handle nicht definiert/ungltig';
8 : message := 'nicht gengend Hauptspeicher frei';
10 : message := 'Environment-Parameter ungltig';
11 : message := 'ungltiges Befehlsformat';
18 : message := 'keine weiteren Dateieintrge/Datei nicht vorhanden';
else begin
Str(code,message);
message := 'DOS - Fehler Nr. ' + message + ' = ' + Error_Code[code];
end;
end;
end;

procedure GetCompleteDOSErrorMessage (code : integer;
var Error,error_cl,error_l : string);
var class,locus : byte;
fehler : integer;
begin
Extended_Error_Code(fehler,class,locus);
Error := Error_Code[fehler];
error_cl := Error_Class[class];
error_l := Error_Locus[locus];
if code <> fehler then writeln('NANUNANA!!!');
end;

procedure read_value(var datei : text; var wert : extended);

type vorzeichen = (plus,minus,none);
zeichentyp = (trennung,sign,value,point,garbage);

const o_komma = Ord(',');
o_space = Ord(' ');
o_semi = Ord(';');
o_lf = 10;
o_cr = 13;
o_null = Ord('0');
o_neun = Ord('9');
o_punkt = Ord('.');
o_e_kl = Ord('e');
o_e_gr = Ord('E');
o_plus = Ord('+');
o_minus = Ord('-');
null = '0';

var puffer1,puffer2 : char;
weiter,raus,basic : boolean;
akt_vorz,alt_vorz,
vorz2 : vorzeichen;
puffer_art,
puffer_art_2 : zeichentyp;

function CheckDelimiter(test : char) : boolean;
var o_test : byte;
begin
o_test := Ord(test);
if ((o_test=o_komma) or (o_test=o_space) or (o_test=o_semi)
or (o_test=o_lf) or (o_test=o_cr))
then CheckDelimiter := true
else CheckDelimiter := false;
end;

function CheckValue(test : char) : boolean;
var o_test : byte;
begin
o_test := Ord(test);
if ((o_test>=o_null) and (o_test<=o_neun))
then CheckValue := true
else CheckValue := false;
end;

function CheckPunkt(test : char) : boolean;
begin
if (Ord(test)=o_punkt)
then CheckPunkt := true
else CheckPunkt := false;
end;

function CheckE(test : char) : boolean;
var o_test : byte;
begin
o_test := Ord(test);
if ((o_test=o_e_kl) or (o_test=o_e_gr))
then CheckE := true
else CheckE := false;
end;

function CheckPlus(test : char) : boolean;
begin
if (Ord(test)=o_plus)
then CheckPlus := true
else CheckPlus := false;
end;

function CheckMinus(test : char) : boolean;
begin
if (Ord(test)=o_minus)
then CheckMinus := true
else CheckMinus := false;
end;

function CheckIOResult : boolean;
var code : integer;
error_m,error_cl,error_l : string;
begin
{$I-}
code := IOResult;
if code<>0
then begin
CheckIOResult := false;
if DOS_Major_Version >= 3 {UNIT ENV}
then
begin
GetCompleteDOSErrorMessage(code,error_m,error_cl,error_l);
writeln('I/O-Fehler ',code,' --> ',error_m);
writeln('I/O-Fehler-Klasse ',error_cl);
writeln('I/O-Fehler-Locus ',error_l);
end
else
begin
GetDOSErrorMessage(code,error_m);
writeln('I/O-Fehler ',code,' --> ',error_m);
end;
StandBy;
end
else CheckIOResult := true;
end;

function puffertest(puffer : char; var vorz : vorzeichen) : zeichentyp;
begin {of puffertest}
puffertest := garbage;
if CheckMinus(puffer) then vorz := minus
else if CheckPlus(puffer)
then vorz := plus
else vorz := none;
if vorz<>none
then puffertest := sign
else if CheckDelimiter(puffer)
then puffertest := trennung
else if CheckPunkt(puffer)
then puffertest := point
else if CheckValue(puffer) then puffertest := value;
end; {of puffertest}

procedure skip(var datei : text; var vorz : vorzeichen; var puffer : char;
var puffertyp : zeichentyp);
begin {of skip}
{$I-}
vorz := none;
puffertyp := garbage;
repeat
if eoln(datei) then readln(datei);
read(datei,puffer);
if not CheckIOResult then begin
ende(raus);
if raus then halt(300);
end;

puffertyp := puffertest(puffer,vorz);
{
case vorz of
plus : write('P');
minus: write('M');
none : write('n');
end;
}
until ((puffertyp<>garbage) or eof(datei));
end; {of skip}

procedure PickUp(var datei : text; basic : boolean; puffer : char;
VAR wert : extended );

var zahl : string;
stop,punkt,raus : boolean;
puffer2 : char;
fehler : integer;
begin {of PickUp}
{$I-}
zahl := '';
punkt := false;
stop := false;
if basic then begin zahl := '0.'; punkt := true; end;
zahl := zahl+puffer;
while ((not eoln(datei) and (not stop))) do
begin
read(datei,puffer);
if not CheckIOResult then begin
ende(raus);
if raus then halt(300);
end;
if ((CheckPunkt(puffer) and punkt) or CheckDelimiter(puffer))
then stop := true
else if (CheckValue(puffer) or (CheckPunkt(puffer) and (not punkt)))
then begin
zahl := zahl+puffer;
if CheckPunkt(puffer) then punkt := true;
end
else if (not CheckE(puffer))
then stop := true
else begin
if (not eoln(datei))
then begin
read(datei,puffer2);
if not CheckIOResult
then begin
ende(raus);
if raus then halt(300);
end;
if (CheckMinus(puffer2) or (CheckPlus(puffer2)))
then zahl := zahl+puffer+puffer2
else stop := true;
end
else stop := true;
end;
end;
Val(zahl,wert,fehler);
if fehler<>0 then begin
HighVideo;
writeln('Fehler beim Einlesen von >',zahl,'< an Position ',fehler,' !!');
NormVideo;
StandBy;
ende(raus);
if raus then halt(301);
end;
end; {of PickUp}

begin {of READ_VALUE}
{$I-}
akt_vorz := none;
alt_vorz := none;

weiter := true;
wert :=0;

while ((not eof(datei)) and weiter) do
begin
basic := false;
alt_vorz := akt_vorz;
skip(datei,akt_vorz,puffer1,puffer_art);
case puffer_art of
value : begin
akt_vorz := alt_vorz;
PickUp(datei,basic,puffer1,wert);
weiter := false;
end;
point : begin
read(datei,puffer2);
if not CheckIOResult then begin
ende(raus);
if raus then halt(300);
end;
puffer_art_2 := puffertest(puffer2,vorz2);
case puffer_art_2 of
value : begin
basic := true;
akt_vorz := alt_vorz;
PickUp(datei,basic,puffer2,wert);
weiter := false;
end;
sign : akt_vorz := vorz2;
trennung : akt_vorz := none;
point : akt_vorz := none;
end;
end;
trennung : akt_vorz := none;
sign : begin
read(datei,puffer2);
if not CheckIOResult then begin
ende(raus);
if raus then halt(300);
end;
puffer_art_2 := puffertest(puffer2,vorz2);
case puffer_art_2 of
value : begin
basic := false;
PickUp(datei,basic,puffer2,wert);
weiter := false;
end;
sign : akt_vorz := vorz2;
trennung : akt_vorz := none;
point : begin
read(datei,puffer2);
if not CheckIOResult
then begin
ende(raus);
if raus then halt(300);
end;
puffer_art_2 := puffertest(puffer2,vorz2);
case puffer_art_2 of
value : begin
basic := true;
PickUp(datei,basic,puffer2,wert);
weiter := false;
end;
sign : akt_vorz := vorz2;
trennung : akt_vorz := none;
point : akt_vorz := none;
end;
end;
end;
end;
end;
end;
if akt_vorz=minus then wert :=-wert;
{$I+}
end; {of READ_VALUE}

procedure read_value_eof(var datei : text; var wert : extended; var ende : boolean);
begin
ende := eof(datei);
if not ende then begin
read_value(datei,wert);
ende := eof(datei);
end;
end;

(****************************************************************************)
(* Zehner-Logarithmus von 'x': *)

FUNCTION lg (x: extended): extended;

CONST rez_ln_10 = 0.4342944819; (* rez_ln_10 = 1 / ln(10) *)

BEGIN
lg :=0;
IF x > 0.0 THEN
lg := Ln(x) * rez_ln_10
ELSE
{CalcError(3, 'lg(x): x <= 0')}
writeln('Argumentfehler: lg(x): x <= 0 !!!')
END;

(****************************************************************************)
(* Berechnung von 'x hoch y': *)

FUNCTION x_hoch_y (x, y: extended): extended;

VAR ganz_y: INTEGER;

BEGIN
IF (x <> 0.0) OR (y <> 0.0) THEN
IF x > 0.0 THEN
x_hoch_y := Exp(y * Ln(x))
ELSE
BEGIN
ganz_y := Trunc(y);
IF ABS(y) > ABS(ganz_y) THEN
{CalcError(3, 'x_hoch_y(x,y): nur ganzzahlige Exponenten zulssig bei x<0')}
writeln('x_hoch_y(x,y): nur ganzzahlige Exponenten zulssig bei x<0')
ELSE
IF x <> 0.0 THEN
IF (ganz_y MOD 2) = 0 THEN
x_hoch_y := Exp(Ln(ABS(x)) * y)
ELSE
x_hoch_y := -Exp(Ln(ABS(x)) * y) (* ungerader Exponent *)
ELSE
x_hoch_y := 0
END
ELSE
{CalcError(3, 'x_hoch_y(x,y): x = 0 und y = 0')}
writeln('x_hoch_y(x,y): x = 0 und y = 0')
END;

(****************************************************************************)

(****************************************************************************)
procedure process_file(seite : styp;
var fertig : boolean;
rechteachse,xlogar,ylogar : boolean;
var aus : text);

function betest(t,v : string): boolean;
var t1 : string;
i : byte;
begin
t1:=t;
for i:=1 to length(t) do t1[i]:=UpCase(t[i]);
while t1[1]=' ' do Delete(t1,1,1);
if t1=v then betest := true else betest :=false;
end;

const b1='BEGIN';
e1='END';

var einn,symbol,test : string;
ein : text;
f : SearchRec;
anzahl : longint;
ch : char;
sym,linie,quadratic,clipping,ende : boolean;
x,y,xa,ya : extended;

begin {of process_file}
writeln('Ende durch leere Eingabe !!');
repeat
write('Daten -Datei (TechPlot-Format!!) : ');
readln(einn);
if einn='' then fertig:=true;
FindFirst(einn,Archive,F);
until ((DOSError=0) or fertig);

if not fertig then
begin
anzahl :=0;
assign(ein,einn);
repeat
write('mit Plotsymbol (j/n) ? ');
readln(ch);
ch := UpCase(ch);
until ((ch='J') or (ch='N'));
if ch='J' then sym := true else sym := false;
repeat
write('durchgezogene Linie (j/n) ? ');
readln(ch);
ch := UpCase(ch);
until ((ch='J') or (ch='N'));
if ch='J' then linie := true else linie := false;
if linie then
begin
repeat
write('Quadratische Interpolation (1) oder Polygonzug (2) ? ');
readln(ch);
ch := UpCase(ch);
until ((ch='1') or (ch='2'));
if ch='1' then quadratic := true else quadratic := false;
repeat
write('Clipping ntig (Achtung, das dauert LANGE) (j/n) ? ');
readln(ch);
ch := UpCase(ch);
until ((ch='J') or (ch='N'));
if ch='J' then clipping := true else clipping := false;
end;

if sym then
begin
write('Plotsymbol (LaTeX-Text) : ');
readln(symbol);
reset(ein);
writeln(aus,'%Datei ',einn,' (Symbole)');
repeat
readln(ein,test);
writeln(aus,'%% ',test);
until ((betest(test,b1)) or eof(ein));
ende := false;
if eof(ein) then ende := true;
write(aus,'% Daten fuer ');
if rechteachse then
if (seite=left)
then write(aus,'linke ')
else write (aus,'rechte ');
writeln(aus,'y-Achse ...');
if not ende then
begin
writeln('\multiput {',symbol,'} at ');
writeln(aus,'\multiput {',symbol,'} at %');
end;
while not ende do
begin
read_value_eof(ein,x,ende);
read_value_eof(ein,y,ende);
if not ende then begin
readln(ein);
Inc(anzahl);
if xlogar then x:=lg(x);
if ylogar then y:=lg(y);
writeln(aus,' ',x:8:6,' ',y:8:6,' %');
writeln(x:8:5,' ',y:8:4);
end
else begin
writeln(' /');
writeln(aus,' /');
end;
end;
end;
if linie then
begin
reset(ein);
anzahl :=0;
writeln(aus,'%Datei ',einn,' (Linie)');
repeat
readln(ein,test);
writeln(aus,'%% ',test);
until ((betest(test,b1)) or eof(ein));
ende := false;
if eof(ein) then ende := true;

if clipping then writeln(aus,'\inboundscheckon');
if quadratic then writeln(aus,'\setquadratic')
else writeln(aus,'\setlinear');
writeln(aus,'\plot ');
while not ende do
begin
read_value_eof(ein,x,ende);
read_value_eof(ein,y,ende);
if not ende then begin
readln(ein);
Inc(anzahl);
if xlogar then x:=lg(x);
if ylogar then y:=lg(y);
xa :=x;
ya :=y;
writeln(aus,' ',x:8:6,' ',y:8:6,' %');
writeln(x:8:4,' ',y:8:4);
end;
end;
if quadratic then
if not odd(anzahl) then
writeln(aus,xa*1.00001:8:6,' ',ya*1.00001:8:6,' %');
writeln(aus,'/');
if clipping then writeln(aus,'\inboundscheckoff');
end;
close(ein);
end;
end; {of process_file}

procedure Einheiten(var unitx,unity,unitry : real; breite,hoehe : real;
rechteachse,xlog,ylog,rylog : boolean);
begin
if xlog then unitx := breite/(lg(xmax)-lg(xmin))
else unitx := breite/(xmax-xmin);
if ylog then unity := HOEHE/(lg(ymax)-lg(ymin))
else unity := hoehe/(ymax-ymin);
if rechteachse then if rylog then unitry := hoehe/(lg(rymax)-lg(rymin))
else unitry := hoehe/(rymax-rymin)
else unitry :=0;
end;

procedure skala (var aus : text;
seite : styp;
unitx,unity : real;
xlog,ylog,rechteachse,xkreuz,ykreuz : boolean;
xmin,xmax,dx,dxsub,ymin,ymax,dy,dysub : real;
xdez,ydez :byte;
unten,oben,rechts,links : string);

procedure Log_schrift(var aus: text; min,max : real;
markiere,kreuz : boolean);
{$I float.typ}
var ort,o2 : float;
expo,code : integer;
stellen,i : byte;
ex : string;
begin
writeln(aus,' ticks logged ');
if kreuz then write(aus,'andacross ');
if markiere then writeln(aus,'numbered ') else writeln(aus,'unlabeled ');

if markiere
then
begin {Zahlen dranschreiben}
write(aus,'withvalues ');
ort := min/10;
repeat
Str(lg(ort):1:0,ex);
Val(ex,expo,code);
{expo := trunc(lg(ort));}
o2 := (x_hoch_y(10,expo));
if ((o2>=min) and (o2<=max))
then write(aus,'$10^{',expo,'}$ ');
ort := 2*o2;
if ((ort<=max) and (ort>=min))
then write(aus,'{\small 2} ');
ort := 3*o2;
if ((ort>=min) and (ort<=max))
then write(aus,'{\small 3} ');
ort := 5*o2;
if ((ort>=min) and (ort<=max))
then write(aus,'{\small 5} ');
ort := 10*o2;
until ort>max;
writeln(aus,' /');
end;

{ticks setzen, normal lang}
write(aus,' at ');
ort := min/10;
repeat
Str(lg(ort):1:0,ex);
Val(ex,expo,code);
{expo := trunc(lg(ort));}
o2 := (x_hoch_y(10,expo));
if expo<0 then stellen := abs(expo) else stellen :=0;
if ((o2>min) and (o2<max))
then write(aus,x_hoch_y(10,expo):1:stellen,' ');
{o2 := ort;}
ort := 2*o2;
if ((ort<max) and (ort>min))
then write(aus,ort:1:stellen,' ');
ort := 3*o2;
if ((ort>min) and (ort<max))
then write(aus,ort:1:stellen,' ');
ort := 5*o2;
if ((ort>min) and (ort<max))
then write(aus,ort:1:stellen,' ');
ort := 10*o2;
until ort>max;
writeln(aus,' /');

{ticks, immer ohne Beschriftung, lang }
writeln(aus,' unlabeled at ');
ort := min/10;
repeat
Str(lg(ort):1:0,ex);
Val(ex,expo,code);
{expo := trunc(lg(ort));}
o2 := (x_hoch_y(10,expo));
if expo<0 then stellen := abs(expo) else stellen :=0;
ort := 4*o2;
if ((ort>min) and (ort<max))
then write(aus,ort:1:stellen,' ');
for i:=6 to 9 do
begin
ort := i*o2;
if ((ort>min) and (ort<max))
then write(aus,ort:1:stellen,' ');
end;
ort := 10*o2;
until ort>max;
writeln(aus,' /');

{ticks, ohne Beschriftung, kurz }
writeln(aus,' unlabeled short at ');
ort := min/10;
repeat
Str(lg(ort):1:0,ex);
Val(ex,expo,code);
{expo := trunc(lg(ort));}
o2 := (x_hoch_y(10,expo));
if expo<=0 then stellen := abs(expo)+1 else stellen :=0;
for i:=1 to 9 do
begin
ort := o2*(1+i*0.2); {1.2, 1.4, ... 2.8 }
if ((ort>min) and (ort<max))
then write(aus,ort:1:stellen,' ');
end;
ort :=3.5*o2;
if ((ort>min) and (ort<max))
then write(aus,ort:1:stellen,' ');
ort :=4.5*o2;
if ((ort>min) and (ort<max))
then write(aus,ort:1:stellen,' ');
ort := 10*o2;
until ort>max;
writeln(aus,' /'); {letztes "at"}
writeln(aus,' /'); {Ende von "\axis"}
end;

var con : text;
begin
assign(con,'con');
rewrite(con);
write('\setcoordinatesystem units <',unitx:1:5,'mm,',unity:1:5,'mm> point at ');
if xlog then write(lg(xmin):1:5,' ')
else write(xmin:1:5,' ');
if ylog then writeln(lg(ymin):1:5)
else writeln(ymin:1:5);

write('\setplotarea x from ');
if xlog then write(lg(xmin):8:5)
else write(xmin:8:5);
write(' to ');
if xlog then write(lg(xmax):8:5)
else write(xmax:8:5);
write(', y from ');
if ylog then write(lg(ymin):8:5)
else write(ymin:8:5);
write(' to ');
if ylog then writeln(lg(ymax):8:5)
else writeln(ymax:8:5);
if seite=left
then
begin
write('\axis bottom shiftedto y=');
if ylog then write(lg(ymin):8:5)
else write(ymin:8:5);
write(' label {',unten,'} ');
if xlog then Log_schrift(con,xmin,xmax,true,xkreuz)
else writeln(' ticks numbered from ',
xmin:8:xdez,' to ',xmax:8:xdez,' by ',dx:8:xdez,
' unlabeled short from ',xmin:8:xdez,' to ',
xmax:8:xdez,' by ',dxsub:8:xdez,' /');

write('\axis top shiftedto y=');
if ylog then write(lg(ymax):8:5)
else write(ymax:8:5);
write(' label {',oben,'} ');
if xlog then Log_schrift(con,xmin,xmax,false,false)
else writeln(' ticks unlabeled from ',
xmin:8:xdez,' to ',xmax:8:xdez,' by ',dx:8:xdez,
' unlabeled short from ',xmin:8:xdez,' to ',
xmax:8:xdez,' by ',dxsub:8:xdez,' /');

write('\axis left shiftedto x=');
if xlog then write(lg(xmin):8:5)
else write(xmin:8:5);
write(' label {',links,'} ');
if ylog then Log_schrift(con,ymin,ymax,true,ykreuz)
else writeln(' ticks numbered from ',
ymin:8:ydez,' to ',ymax:8:ydez,' by ',dy:8:ydez,
' unlabeled short from ',ymin:8:ydez,' to ',
ymax:8:ydez,' by ',dysub:8:ydez,' /');
if not rechteachse then
begin
write('\axis right shiftedto x=');
if xlog then write(lg(xmax):8:5)
else write(xmax:8:5);
write(' label {',rechts,'} ');
if ylog then Log_schrift(con,ymin,ymax,false,false)
else writeln(' ticks unlabeled from ',
ymin:8:ydez,' to ',ymax:8:ydez,' by ',dy:8:ydez,
' unlabeled short from ',ymin:8:ydez,' to ',
ymax:8:ydez,' by ',dysub:8:ydez,' /');
end;
end
else
begin
write('\axis right shiftedto x=');
if xlog then write(lg(xmax):8:5)
else write(xmax:8:5);
write(' label {',rechts,'} ');
if ylog then Log_schrift(con,ymin,ymax,true,ykreuz)
else writeln(' ticks numbered from ',
ymin:8:ydez,' to ',ymax:8:ydez,' by ',dy:8:ydez,
' unlabeled short from ',ymin:8:ydez,' to ',
ymax:8:ydez,' by ',dysub:8:ydez,' /');
end;
close(con);
write(aus,'\setcoordinatesystem units <',unitx:1:5,'mm,',unity:1:5,'mm> point at ');
if xlog then write(aus,lg(xmin):1:6,' ')
else write(aus,xmin:1:6,' ');
if ylog then writeln(aus,lg(ymin):1:6)
else writeln(aus,ymin:1:6);

write(aus,'\setplotarea x from ');
if xlog then write(aus,lg(xmin):1:6)
else write(aus,xmin:1:6);
write(aus,' to ');
if xlog then write(aus,lg(xmax):1:6)
else write(aus,xmax:1:6);
write(aus,', y from ');
if ylog then write(aus,lg(ymin):1:6)
else write(aus,ymin:8:5);
write(aus,' to ');
if ylog then writeln(aus,lg(ymax):1:6)
else writeln(aus,ymax:1:6);
if seite=left
then
begin
write(aus,'\axis bottom shiftedto y=');
if ylog then write(aus,lg(ymin):1:6)
else write(aus,ymin:1:6);
write(aus,' label {',unten,'} ');
if xlog then Log_schrift(aus,xmin,xmax,true,xkreuz)
else begin
write(aus,' ticks ');
if xkreuz then write(aus,'andacross ');
writeln(aus,'numbered from ',
xmin:1:xdez,' to ',xmax:1:xdez,' by ',dx:1:xdez,
' unlabeled short from ',xmin:1:xdez+3,' to ',
xmax:1:xdez+3,' by ',dxsub:1:xdez+3,' /');
end;

write(aus,'\axis top shiftedto y=');
if ylog then write(aus,lg(ymax):1:6)
else write(aus,ymax:1:6);
write(aus,' label {',oben,'} ');
if xlog then Log_schrift(aus,xmin,xmax,false,false)
else writeln(aus,' ticks unlabeled from ',
xmin:1:xdez+2,' to ',xmax:1:xdez+2,' by ',dx:1:xdez+2,
' unlabeled short from ',xmin:1:xdez+3,' to ',
xmax:1:xdez+3,' by ',dxsub:1:xdez+3,' /');

write(aus,'\axis left shiftedto x=');
if xlog then write(aus,lg(xmin):1:6)
else write(aus,xmin:1:6);
write(aus,' label {',links,'} ');
if ylog then Log_schrift(aus,ymin,ymax,true,ykreuz)
else begin
write(aus,' ticks ');
if ykreuz then write(aus,'andacross ');
writeln(aus,'numbered from ',
ymin:1:ydez,' to ',ymax:1:ydez,' by ',dy:1:ydez,
' unlabeled short from ',ymin:1:ydez+3,' to ',
ymax:1:ydez+3,' by ',dysub:1:ydez+3,' /');
end;
if not rechteachse then
begin
write(aus,'\axis right shiftedto x=');
if xlog then write(aus,lg(xmax):1:6)
else write(aus,xmax:1:6);
write(aus,' label {',rechts,'} ');
if ylog then Log_schrift(aus,ymin,ymax,false,false)
else writeln(aus,' ticks unlabeled from ',
ymin:1:ydez+2,' to ',ymax:1:ydez+2,' by ',dy:1:ydez+2,
' unlabeled short from ',ymin:1:ydez+3,' to ',
ymax:1:ydez+3,' by ',dysub:1:ydez+3,' /');
end;
end
else
begin
write(aus,'\axis right shiftedto x=');
if xlog then write(aus,lg(xmax):1:6)
else write(aus,xmax:1:6);
write(aus,' label {',rechts,'} ');
if ylog then Log_schrift(aus,ymin,ymax,true,ykreuz)
else begin
write(aus,' ticks ');
if ykreuz then write(aus,'andacross ');
writeln(aus,'numbered from ',
ymin:1:ydez,' to ',ymax:1:ydez,' by ',dy:1:ydez,
' unlabeled short from ',ymin:1:ydez+3,' to ',
ymax:1:ydez+3,' by ',dysub:1:ydez+3,' /');
end;
end;

end;

begin
writeln;
writeln(' Datei-Konverter Daten -->PiCTeX input ... ');
writeln('(c) Christian Bttger, Inst. f. Metallphysik, TU Braunschweig');
writeln(' Version 1.0, 3.7.1991 ');
writeln;
Get_Dos_Version(dos_major_version,dos_minor_version);

write('PiCTeX-Datei : ');readln(ausn) ;
assign(aus,ausn);
rewrite(aus);

writeln;
write('X-Achse : Minimum = ');readln(xmin);
write('X-Achse : Maximum = ');readln(xmax);
repeat
write('x-Achse logarithmisch (j/n) ? ');
readln(ch);
ch := UpCase(ch);
until ((ch='N') or (ch='J'));
if ch='J' then xlog := true else xlog := false;
if not xlog
then begin
write('X-Achse : Schrittweite = ');readln(dx);
write('X-Achse : Schrittweite Sub-Unterteilungen = ');readln(dxsub);
write('X-Achse : Dezimalstellen der Beschriftung = ');readln(xdez);
end;

repeat
write('x-Achse Markierungen durchziehen (Gitter) (j/n) ? ');
readln(ch);
ch := UpCase(ch);
until ((ch='N') or (ch='J'));
if ch='J' then xkreuz := true else xkreuz := false;

writeln;
writeln('Eingabe der Daten fr die (linke) Y-Achse ...');
write('y-Achse : Minimum = ');readln(ymin);
write('y-Achse : Maximum = ');readln(ymax);
repeat
write('(linke) y-Achse logarithmisch (j/n) ? ');
readln(ch);
ch := UpCase(ch);
until ((ch='N') or (ch='J'));
if ch='J' then ylog := true else ylog := false;
if not ylog
then begin
write('y-Achse : Schrittweite = ');readln(dy);
write('y-Achse : Schrittweite Sub-Unterteilungen = ');readln(dysub);
write('y-Achse : Dezimalstellen der Beschriftung = ');readln(ydez);
end;
repeat
write('(linke) y-Achse Markierungen durchziehen (Gitter) (j/n) ? ');
readln(ch);
ch := UpCase(ch);
until ((ch='N') or (ch='J'));
if ch='J' then ykreuz := true else ykreuz := false;

writeln;
repeat
write('zweite unabhngige Skala auf rechter y-Achse (j/n) ? ');
readln(ch);
ch := UpCase(ch);
until ((ch='N') or (ch='J'));
if ch='J' then rechteachse :=true else rechteachse:=false;
if rechteachse then
begin
writeln;
write('rechte y-Achse : Minimum = ');readln(rymin);
write('rechte y-Achse : Maximum = ');readln(rymax);
repeat
write('rechte y-Achse logarithmisch (j/n) ? ');
readln(ch);
ch := UpCase(ch);
until ((ch='N') or (ch='J'));
if ch='J' then rylog := true else rylog := false;
if not rylog
then begin
write('rechte y-Achse : Schrittweite = ');readln(rdy);
write('rechte y-Achse : Schrittweite Sub-Unterteilungen = ');readln(rdysub);
write('rechte y-Achse : Dezimalstellen der Beschriftung = ');readln(rydez);
end;
repeat
write('rechte y-Achse Markierungen durchziehen (Gitter) (j/n) ? ');
readln(ch);
ch := UpCase(ch);
until ((ch='N') or (ch='J'));
if ch='J' then rykreuz := true else rykreuz := false;
writeln;
end;
write('Beschriftung Unterkante : ');readln(unten);
write('Beschriftung Oberkante : ');readln(oben);
write('Beschriftung rechts : ');readln(rechts);
write('Beschriftung links : ');readln(links);
writeln;

write('Breite des Bildes in mm = ');readln(breite);
write('Hhe des Bildes in mm = ');readln(hoehe);
writeln;
write('Unterschrift des Bildes (\caption) : '); readln(unterschrift);
write('berschrift des Bildes : '); readln(ueberschrift);
write('LaTeX-Label des Bildes : ');readln(labelstr);
repeat
writeln('Sprache des Textes:');
write(' a=austrian, e=english, f=french, g=german, u=USenglish ? ');
readln(sprache);
sprache := UpCase(sprache);
until sprache in ['A','E','F','G','U'];

writeln;
writeln('und nun die Zwischenspeicherung ...');
savename :='';
repeat
write('Dateiname fr \savelinesandcurves bzw. \replot = ');
readln(savename);
until savename<>'';
write('Kommentar im Save-File = ');
readln(savekomm);
Einheiten(unitx,unity,unitry,breite,hoehe,rechteachse,xlog,ylog,rylog);

writeln('\begin{figure}[htb]');
writeln('\originalTeX');
writeln('\[ %horizontal zentrierte Ausgabe an');
writeln('\beginpicture');

writeln(aus,'\begin{figure}[htb]');
writeln(aus,'\originalTeX');
writeln(aus,'\[ %zentrierte Ausgabe an');
writeln(aus,'\beginpicture');
writeln(aus,'\savelinesandcurves on "',savename,'"');
writeln(aus,'\writesavefile {',savekomm,'}');

skala (aus,left,
unitx,unity,
xlog,ylog,rechteachse,xkreuz,ykreuz,
xmin,xmax,dx,dxsub,ymin,ymax,dy,dysub,xdez,ydez,
unten,oben,rechts,links);

writeln(aus,'\plotheading {',ueberschrift,'}');
writeln(aus,'%\replot "',savename,'"');

fertig := false;
repeat
writeln;
if rechteachse then writeln('Nur Daten fr die LINKE (!!) y- Achse jetzt !!!!');
process_file(left,fertig,rechteachse,xlog,ylog,aus);
until fertig;
if rechteachse then
begin
skala (aus,right,
unitx,unitry,
xlog,rylog,rechteachse,xkreuz,rykreuz,
xmin,xmax,dx,dxsub,rymin,rymax,rdy,rdysub,xdez,rydez,
unten,oben,rechts,links);

fertig := false;
repeat
writeln;
writeln('Nur Daten fr die RECHTE (!!) y- Achse ab jetzt !!!!');
process_file(right,fertig,rechteachse,xlog,rylog,aus);
until fertig;
end;

writeln(aus,'\dontsavelinesandcurves');
writeln(aus,'\endpicture');
writeln(aus,'\]');
writeln(aus,'\germanTeX');
write(aus,'\selectlanguage{\');
case sprache of
'A' : writeln(aus,'austrian}');
'E' : writeln(aus,'english}');
'F' : writeln(aus,'french}');
'G' : writeln(aus,'german}');
'U' : writeln(aus,'USenglish}');
end;

writeln(aus,'\caption{',unterschrift,' \label{',labelstr,'}}');
writeln(aus,'\end{figure}');

writeln('\endpicture');
writeln('\]');
writeln('\germanTeX');
write('\selectlanguage{\');
case sprache of
'A' : writeln('austrian}');
'E' : writeln('english}');
'F' : writeln('french}');
'G' : writeln('german}');
'U' : writeln('USenglish}');
end;

writeln('\caption{',unterschrift,' \label{',labelstr,'}}');
writeln('\end{figure}');

close(aus);
end.