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 Sender: Borland Pascal Discussion Group From: "John M. Kelsey" Subject: Cursor questions To: "Christian Boettger, TU Braunschweig, FRG" 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 (o2min)) then write(aus,ort:1:stellen,' '); ort := 3*o2; if ((ort>min) and (ortmin) and (ortmax; 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 (ortmin) and (ortmax; 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 (ortmin) and (ortmin) and (ortmax; 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.