diff options
Diffstat (limited to 'support/pictex-converter/pictexte.pas')
-rw-r--r-- | support/pictex-converter/pictexte.pas | 1391 |
1 files changed, 1391 insertions, 0 deletions
diff --git a/support/pictex-converter/pictexte.pas b/support/pictex-converter/pictexte.pas new file mode 100644 index 0000000000..873ab9b1b9 --- /dev/null +++ b/support/pictex-converter/pictexte.pas @@ -0,0 +1,1391 @@ +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" <C445585@UMCVMB.BITNET> +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: howell@cod.nosc.mil (Susan Howell) +Message-Id: <9002140206.AA01529@cod.nosc.mil> +To: ADD.@BOETT +Cc: howell@cod.nosc.mil +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%DBSTU1.bitnet@cunyvm.cuny.edu +************************************************************************) + +{***************************************************************************} +{ 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. + + + + + + + |