Unit Tek4100 ;
(* ------------------------------------------------------------------ *)
(* Tektronics 4100 Graphics emulation unit *)
(* ------------------------------------------------------------------ *)
Interface
Uses Crt,Graph,Printer, (* Standard Turbo Pascal Units *)
Fonts,Drivers, (* Optional Turbo Pascal generated Units *)
KGlobals,Sysfunc,
Modempro,Packets;
Const
Gversion = ' a' ;
enq = $05 ; EQ = #$05 ;
bel = $07 ; BL = #$07 ;
ff_ = $0C ; FF = #$0C ;
cr_ = $0D ; CR = #$0D ;
etb = $17 ; EB = #$17 ;
can = $18 ; CN = #$18 ;
sub = $1A ; SB = #$1A ;
esc = $1B ; EC = #$1B ;
fs_ = $1C ; FS = #$1C ;
gs_ = $1D ; GS = #$1D ;
rs_ = $1E ; RS = #$1E ;
us_ = $1F ; US = #$1F ;
Var
NewGraph : Boolean ;
Graphics : string [25] ;
Afile : file of byte ;
filename : string[25] ;
achar : char ;
Procedure Tektronics (lastbyte : byte) ;
Implementation
(* ------------------------------------------------------------------ *)
Type
screen = array [0..$7FFF] of byte ;
var (* Tek 4100 variables *)
tek4010 : boolean ;
abyte,bbyte : byte ;
result,
Ysize : Integer ;
BeginPanel : boolean ;
BeginPanelX,BeginPanelY,
LastX,LastY,NewX,NewY,
XDim,YDim,
CursorX,CursorY,
SGPosX,SGPosY,
X1,X2,Y1,Y2,
WindowX,WindowY : integer ;
Xscale,Yscale : Real ;
HiY, LoY, HiX, LoX,
ExtraY, ExtraX : byte ;
NeedLoY,DrawVector : Boolean ;
GTslant,GTbackindex,
GTdashindex,GTFont,
height,
GTwidth,GTheight,GTspacing,
PickId,LineIndex,MarkerNumber,
GTpath,FillPattern,GTprecision,
Unknown1,Unknown2,Unknown3,
Mantissa,Exponent,
TextIndex,LineStyle,
FixLevel,ErrorLevel,
GTB_FontNumber,
SegmentNum,OpenSegment,
PixSurface,ALUmode,BitsPerPixel,
DevFunCode,DistanceFilter,TimeFilter,
ViewNumber,DAlines : integer ;
GTrotation : real ;
SurfaceNumber,
ColorCoord1,ColorCoord2,ColorCoord3,
ColorMode,ColorOverMode,GrayMode,
ColorMixI,I :integer ;
ColorMix : Array [1..64] of integer ;
GINColor : shortint ;
GTB_FontChar : byte ;
BoundfillPat,
GINenable ,
GAmode,DAenable,
DAvisibility : boolean ;
PI : integer ;
alphastr : string ;
alphacnt : integer ;
GraphDriver,GraphMode : integer ;
palette : PaletteType ;
PolyGon : array [1..127] of PointType ;
GraphScreen,SaveScreen : ^screen ;
SaveScreenP : pointer ;
(* ------------------------------------------------------------------ *)
Procedure CrossHair ( X,Y : integer );
const CrossX = 24;
CrossY = 10;
var x1,y1,x2,y2 : integer;
begin (* Cross Hair *)
x1 := X - CrossX; if x1 < 0 then x1 := 0;
x2 := X + CrossX; if x2 >= XDim then x2 := XDim - 1;
y1 := Y - CrossY; if y1 < 0 then y1 := 0;
y2 := Y + CrossY; if y2 >= Ydim then y2 := YDim - 1;
for x1 := x1 to x2 do PutPixel(x1,(YDim-Y),GetPixel(x1,(YDim-Y)) xor $0F);
for y1 := y1 to y2 do PutPixel(X,(YDim-y1),GetPixel(X,(YDim-y1)) xor $0F);
end ; (* CrossHair *)
Procedure Mark( X,Y,Marktype : integer );
Begin (* Mark *)
Case Marktype of
0: Begin { Dot }
line(X,Y,X,Y);
End ; { Dot }
1: Begin { Small Cross }
Line(X,Y-2,X,Y+2);
Line(X-2,Y,X+2,Y);
End ; { Small Cross }
2: Begin { Cross }
Line(X,Y-3,X,Y+3);
Line(X-3,Y,X+3,Y);
End ; { Cross }
3: Begin { Star }
Line(X-2,Y-2,X+2,Y+2);
Line(X-2,Y+2,X+2,Y-2);
Line(X,Y-3,X,Y+3);
End ; { Star }
4: Begin { Zero }
Line(X-1,Y-4,X+1,Y-4);
Line(X-2,Y-3,X-2,Y+3);
Line(X+2,Y-3,X+2,Y+3);
Line(X-1,Y+4,X+1,Y+4);
End ; { Zero }
5: Begin { X }
Line(X-2,Y-3,X+2,Y+3);
Line(X-2,Y+3,X+2,Y-3);
End ; { X }
6: Begin { Square }
Line(X-2,Y-2,X+2,Y-2);
Line(X-2,Y+2,X-2,Y-2);
Line(X+2,Y-2,X+2,Y+2);
Line(X-2,Y+2,X+2,Y+2);
End ; { Square }
7 : Begin { Diamond }
Line(X-2,Y,X,Y-2);
Line(X-2,Y,X,Y+2);
Line(X,Y-2,X+2,Y);
Line(X,Y+2,X+2,Y);
End ; { Diamond }
8 : Begin { Square and Dot }
Line(X-2,Y-2,X+2,Y-2);
Line(X-2,Y+2,X-2,Y-2);
Line(X+2,Y-2,X+2,Y+2);
Line(X-2,Y+2,X+2,Y+2);
Line(X,Y,X,Y);
End ; { Square and Dot }
9 : Begin { Diamond and Dot }
Line(X-2,Y,X,Y-2);
Line(X-2,Y,X,Y+2);
Line(X,Y-2,X+2,Y);
Line(X,Y+2,X+2,Y);
Line(X,Y,X,Y);
End ; { Diamond and Dot }
10: Begin { Square and cross }
Line(X-2,Y-2,X+2,Y-2);
Line(X-2,Y+2,X-2,Y-2);
Line(X+2,Y-2,X+2,Y+2);
Line(X-2,Y+2,X+2,Y+2);
Line(X-1,Y-1,X-1,Y-1);
Line(X-1,Y+1,X-1,Y+1);
Line(X+1,Y-1,X+1,Y-1);
Line(X+1,Y+1,X+1,Y+1);
End ; { Square and cross }
End ; (* case marktype *)
End ; (* Mark *)
(* ----------------------------------------------------------------- *)
(* ****************************************************************** *)
Procedure Tektronics (lastbyte : byte) ;
Const
BitCheck = $60 ;
LoYBit = $60 ;
LoXBit = $40 ;
HiBit = $20 ;
Bit6 = $20 ;
FiveBits = $1F ;
pattern : array [0..3] of word = ($FFF0,$333F,$7FE6,$F0F0);
Var
TekState, Done,
TEK4014LineStyle : boolean ;
abyte : byte ;
achar : char ;
Temp,ix : Integer ;
Label VectorMode,VectorContinue,exit ;
(* --------------------------------------------------------------- *)
Procedure GetCoord(var X,Y : integer);
label exit ;
BEGIN (* Get X,Y Coordinates *)
NeedLoY := false ;
IF (abyte and BitCheck) = HiBit THEN
Begin (* HiY *)
HiY := abyte and FiveBits ;
If ReadMchar(abyte) then else goto exit;
End ; (* HiY *)
IF (abyte and BitCheck) = LoYBit THEN
BEGIN (* LoYBit *)
LoY := abyte and FiveBits;
IF (abyte and $10) = 0 then
begin (* Assume Extra bits *)
ExtraX := abyte and $03 ;
ExtraY := (abyte and $0C) shr 2 ;
NeedLoY := true ;
end (* Assume Extra bits *)
else
LoY := abyte and FiveBits;
If ReadMchar(abyte) then else goto exit;
END ; (* LoYBit or Extra Bit *)
IF ((abyte and BitCheck) = LoYBit) THEN
BEGIN (* LoYBit *)
LoY := abyte and FiveBits;
NeedLoY := false ;
If ReadMchar(abyte) then else goto exit ;
End (* LoYBit *)
ELSE
If NeedLoY then
Begin {Extra bit was really LoY bits }
NeedLoY := false ;
ExtraX := 0 ;
ExtraY := 0 ;
End ;
IF (abyte and BitCheck) = HiBit THEN
Begin (* HiX *)
HiX := abyte and FiveBits ;
If ReadMchar(abyte) then else goto exit;
End ; (* HiX *)
IF (abyte and BitCheck) = LoXBit THEN
BEGIN (* LoXBit *)
LoX := abyte and FiveBits;
X := ((HiX shl 5 + LoX) shl 2 ) + ExtraX ;
Y := ((HiY shl 5 + LoY) shl 2 ) + ExtraY ;
END ; (* LoXBit *)
exit :
END ; (* Get X,Y Coordinates *)
(* ------------------------------------------------------------------ *)
Function GetInteger : integer ;
var Hi1,Hi2,Low : byte ;
label exit ;
Begin (* GetInteger *)
Hi1 := 0 ; Hi2 := 0 ; Low := 0 ;
If ReadMchar(abyte) then else goto exit;
If (abyte and $40) <> 0 then
begin (* Hi byte *)
Hi1 := (abyte and $3F);
If ReadMchar(abyte) then else goto exit;
if (abyte and $40) <> 0 then
begin (* Hi2 byte *)
Hi2 := Hi1 ;
Hi1 := abyte and $3F ;
If ReadMchar(abyte) then else goto exit ;
end ; (* Hi2 byte *)
end ; (* Hi byte *)
Low := abyte and $0F ;
if (abyte and $10) <> 0 then
GetInteger := Hi2 shl 10 + Hi1 shl 4 + Low
else
GetInteger := 0 - (Hi2 shl 10 + Hi1 shl 4 + Low) ;
exit :
End ; (* GetInteger *)
(* -------------------------------------------------------------------- *)
Function HLScolor(Hue,Lightness,Saturation : integer): integer;
(* This function returns a color value (0-15) for a given *)
(* Hue,Lightness,and Saturation *)
Const
HueTable : array [0..12] of integer =(Blue,magenta,red,brown,green,cyan,
LightBlue,lightmagenta,lightred,yellow,lightgreen,lightCyan,blue);
Begin (* HLS color *)
(* Check Lightness 100 for white , 0 for Black *)
if Lightness = 100 then HLSColor := white
else
if Lightness = 0 then HLSColor := black
else
if Saturation = 0 then (* no color - GRAY *)
if Lightness >= 50 then HLSColor := LightGray
else HLSColor := DarkGray
else
If Lightness < 50 then
HLSColor := HueTable[(Hue+30) div 60 ]
else
HLSColor := HueTable[((Hue+30) div 60)+6];
End ; (* HLS color *)
(* ------------------------------------------------------------------------ *)
Function PaletteIndex ( Color : shortint) : shortint ;
(* This function returns the PaletteIndex for a given color. *)
(* If the color is not found in the Palette, the index is set to one. *)
Var Pal : PaletteType ;
i : shortint ;
Label exit ;
Begin (* PaletteIndex *)
GetPalette(Pal);
For i := 0 to Pal.Size-1 do
If Pal.Colors[i] = Color then goto exit ;
i := 1 ;
Exit :
PaletteIndex := i ;
End ; (* PaletteIndex *)
(* ------------------------------------------------------------------------ *)
Procedure GIN ;
var Done : boolean ;
XGin,YGin : integer ;
SaveColor : shortint ;
Begin (* GIN - Graphics INput *)
Done := false;
repeat
begin (* move cursor *)
SaveColor := GetColor ;
SetColor(PaletteIndex(GINcolor));
CrossHair(CursorX, CursorY); {draw it}
REPEAT UNTIL KeyChar(abyte,bbyte);
CrossHair(CursorX, CursorY); {erase it}
if abyte = 0 then
begin {special key}
case bbyte of
$48: begin {up arrow}
CursorY := CursorY + 1 ;
if CursorY >= YDim then CursorY := (YDim - 1) ;
end; {up arrow}
$4B: begin {left arrow}
CursorX := CursorX - 1 ;
if CursorX < 0 then CursorX := 0;
end ; {left arrow}
$4D: begin {right arrow}
CursorX := CursorX + 1 ;
if CursorX >= XDim then CursorX := (XDim - 1) ;
end; {right arrow}
$50: begin {down arrow}
CursorY := CursorY - 1 ;
if CursorY < 0 then CursorY := 0;
end; {down arrow}
$4F: begin {END}
Done := true;
SendChar($0D);
end; {END}
else
{not recognized}
end (* of case *);
end { special key }
else
begin (* send cursor location *)
SendChar(abyte);
if tek4010 then
begin (* TEK4010 GIN *)
XGin := Round(CursorX / XScale) shr 2 ;
SendChar((XGin shr 5) or Bit6 ) ; (* Hi X *)
SendChar((XGin and FiveBits) or Bit6); (* Lo X *)
YGin := Round(CursorY / YScale) shr 2 ;
SendChar((YGin shr 5) or Bit6 ) ; (* Hi Y *)
SendChar((YGin and FiveBits) or Bit6); (* Lo Y *)
SendChar($0D);
Done := True;
end (* TEK4010 GIN *)
else
begin (* TEK4100 GIN *)
YGin := Round((CursorY / YScale) * (4096 / windowY));
XGin := Round((CursorX / XScale) * (4096 / windowX));
SendChar(((YGin shr 7) and FiveBits) or Bit6); (* Hi Y *)
SendChar(((YGin and $03) shl 2) or
(XGin and $03) or $60 ); (* Extra bits *)
SendChar(((YGin shr 2) and FiveBits) or $60 ); (* Lo Y *)
SendChar(((XGin shr 7) and FiveBits) or Bit6); (* Hi X *)
SendChar(((XGin shr 2) and FiveBits) or $40 ); (* Lo X *)
SendChar($0D);
Done := True;
end (* TEK4100 GIN *)
end; (* send cursor location *)
end until Done; (* move cursor *)
SetColor(SaveColor);
End ; (* GIN - Graphics INput *)
Function PNumber (var abyte : byte) : integer ;
var Num : integer ;
Begin (* PNumber *)
Num := 0 ;
While chr(abyte) in ['0'..'9'] do
Begin (* get number *)
Num := (Num * 10) + (abyte-$30) ;
If ReadMchar(abyte) then ;
End ; (* get number *)
PNumber := Num ;
End ; (* PNumber *)
(* ==================== Graphic Escape State ======================= *)
Procedure TekEscapeSeq ;
var Pn : array [1..10] of Integer ;
i,j,k : integer ;
tempstr : string[3] ;
label getnum,NextNum,DoCase,exit ;
Begin (* Graphic Escape State *)
(* savescreen^ := GraphScreen^ ; *)
(* GetImage(0,0,Xdim,Ydim,SaveScreenP^); *)
If ReadMchar(abyte) then else goto exit;
case chr(abyte) of
FF : (* PAGE *)
begin
newgraph := true ;
(* repeat until keypressed ;
achar := readkey ; *)
end ;
SB : (* Enable 4010 GIN *)
GIN ;
CR : outtext(' UNKNOWN ') ; (* unknown *)
'[': Begin (* Left square bracket *)
SetTextStyle(SmallFont,0,4) ;
If ReadMchar(abyte) then
CASE chr(abyte) of (* Second level *)
'A': CursorUp ;
'B': CursorDown ;
'C': CursorRight ;
'D': CursorLeft ;
'J': ; (* Erase End of Display *)
'K': ; (* Erase End of Line *)
'?': If ReadMchar(abyte) then
goto Getnum; (* Modes *)
'f',
'H': Moveto(1,1); (* Cursor Home *)
'g': ; (* Cleartab *)
'}',
'm': begin (* Normal Video - Exit all attribute modes *)
SetColor(LightGray);
end ; (* Normal Video - Exit all attribute modes *)
'r': begin (* Reset Margin *)
Moveto(1,1);
end ; (* Reset Margin *)
'c','h','l','n',
'x': Begin Pn[1] := 0 ; Goto DoCase ; End ;
';': Begin Pn[1] := 0 ; k := 1 ; Goto nextnum ; End ;
else (* Pn - got a number *)
Getnum: Begin (* Esc [ Pn...Pn x functions *)
Pn[1] := PNumber(abyte);
k := 1 ;
Nextnum: While abyte = ord(';') do
Begin (* get Pn[k] *)
If ReadMchar(abyte) then
If chr(abyte) = '?' then
If ReadMchar(abyte) then ; (* Ignore '?' *)
k:=k+1 ;
Pn[k] := PNumber(abyte);
End ; (* get Pn[k] *)
Pn[k+1] := 1 ;
DoCase: CASE chr(abyte) of (* third level *)
'A': MoveTo(GetX,GetY-Pn[1]) ; { Cursor Up }
'B': MoveTo(GetX,GetY+Pn[1]) ; { Cursor Down }
'C': MoveTo(GetX+Pn[1],GetY) ; { Cursor Right}
'D': MoveTo(GetX-Pn[1],GetY) ; { Cursor Left }
'f',
'H': Begin (* Direct cursor address *)
If Pn[2] = 0 then Pn[2] := 1 ;
If Pn[2] > 80 then Pn[2] := 80 ;
Moveto(Pn[2]*(XDim div 80),Pn[1]*(Ydim div 24));
End ;(* Direct cursor address *)
'c': Begin (* Device Attributes *)
(* Send Esc[?1;0c *)
Sendchar(Esc); Sendchar(ord('['));
Sendchar(ord('?')); Sendchar(ord('1'));
Sendchar(ord(';')); Sendchar(ord('0'));
Sendchar(ord('c'));
End ; (* Device Attributes *)
'g': (* clear tabs *) ;
'h': (* Set Mode *) ;
'l': (* Reset Mode *) ;
'i': Begin (* Printer Screen on / off *)
End ; (* Printer Screen on / off *)
'q': FatCursor(Pn[1]=1); (* for series/1 insert mode *)
'n': If Pn[1] = 5 then
Begin (* Device Status Report *)
(* Send Esc[0n *)
Sendchar(Esc);Sendchar(ord('['));
Sendchar(ord('0'));Sendchar(ord('n'));
End (* Device Status Report *)
else
If Pn[1] = 6 then
Begin (* Cursor Position Report *)
Sendchar(Esc);Sendchar(ord('['));
STR(WhereY,tempstr); (* ROW *)
Sendchar(ord(tempstr[1]));
If length(tempstr)=2 then
Sendchar(ord(tempstr[2]));
Sendchar(ord(';'));
STR(WhereX,tempstr); (* COLUMN *)
Sendchar(ord(tempstr[1]));
If length(tempstr) = 2 then
Sendchar(ord(tempstr[2]));
Sendchar(ord('R'));
End ; (* Cursor Position Report *)
'x': If Pn[1]<=1 then
Begin (* Request terminal Parameters *)
Sendchar(Esc); Sendchar(ord('['));
If Pn[1] = 0 then Sendchar(ord('2'))
else Sendchar(ord('3')); (* sol *)
Sendchar(ord(';')); (* parity *)
If parity = OddP then Sendchar(ord('4'))
else
If parity = EvenP then Sendchar(ord('5'))
else Sendchar(ord('1')) ;
Sendchar(ord(';'));
Sendchar(ord('2')); (* nbits *)
Sendchar(ord(';'));
For j := 1 to 2 do
Begin (* Xspeed ,Rspeed *)
Case baudrate of
300 : begin Sendchar(ord('4'));
Sendchar(ord('8')); end ;
600 : begin Sendchar(ord('5'));
Sendchar(ord('6')); end ;
1200 : begin Sendchar(ord('6'));
Sendchar(ord('4')); end ;
2400 : begin Sendchar(ord('8'));
Sendchar(ord('8')); end ;
4800 : begin Sendchar(ord('1'));
Sendchar(ord('0'));
Sendchar(ord('4')); end ;
9600 : begin Sendchar(ord('1'));
Sendchar(ord('1'));
Sendchar(ord('2')); end ;
19200 : begin Sendchar(ord('1'));
Sendchar(ord('2'));
Sendchar(ord('0')); end ;
end; (* case *)
Sendchar(ord(';'));
End ; (* Xspeed ,Rspeed *)
Sendchar(ord('1')); (* clkmul *)
Sendchar(ord(';'));
Sendchar(ord('0')); (* flags *)
Sendchar(ord('x'));
End ; (* Request terminal Parameters *)
'm',
'}': For j := 1 to k do
Case Pn[j] of (* Field specs *)
0: begin (* Normal *)
SetColor(LightGray) ;
end ;
1: begin (* High Intensity *)
SetColor(White) ;
end ;
4: SetColor(LightBlue) ; (* Underline *)
5: begin (* Blink *)
end ;
7: begin (* Reverse *)
end ;
8: Begin (* Invisible *)
SetColor(Black);
SetBkColor(Black);
end ;
30: SetColor(Black);
31: SetColor(Red);
32: SetColor(Green);
33: SetColor(brown);
34: SetColor(Blue);
35: SetColor(Magenta);
36: SetColor(Cyan);
37: SetColor(Lightgray);
40: SetBkColor(Black);
41: SetBkColor(Red);
42: SetBkColor(Green);
43: SetBkColor(Brown);
44: SetBkColor(Blue);
45: SetBkColor(Magenta);
46: SetBkColor(Cyan);
47: SetBkColor(LightGray);
End ; (* case of Field specs *)
'r': Begin (* set margin *)
End ; (* Set margin *)
'J': Case Pn[1] of
0: ; (* clear to end of screen *)
1: ; (* clear to beginning *)
2: ; (* clear all of screen *)
End ; (* J - Pn Case *)
'K': Case Pn[1] of
0: ; (* clear to end of line *)
1: ; (* clear to beginning *)
2: ; (* clear line *)
End ; (* J - Pn Case *)
'L': For i := 1 to Pn[1] do (* Insert Line *) ;
'M': For i := 1 to Pn[1] do (* Delete Line *) ;
'@': For i := 1 to Pn[1] do (* InsertChar *) ;
'P': For i := 1 to Pn[1] do (* DeleteChar *) ;
End ; (* Case third level *)
End ; (* Esc [ Pn...Pn x functions *)
End ; (* second level Case *)
End ; (* Left square bracket *)
'%': Begin (* Select Code *)
If ReadMchar(abyte) then else goto exit ;
if abyte = ord('!') then
begin (* get code *)
If ReadMchar(abyte) then else goto exit;
case chr(abyte) of
'0' : Begin
TekState := True ; { TEK }
Ysize := 4096 ;
Yscale := YDim / Ysize ;
End ;
'1' , { ANSI }
'2' , { EDIT }
'3' : TekState := false ; { VT52 }
end ; (* case *)
end ; (* get code *)
End ; (* Select Code *)
'#': (* Report syntax Mode *) ;
'8',
'9',
':',
';': (* Set 4014 Alpha text size *) ;
CN : (* Enter Bypass Mode *) ;
EB : (* 4010 Hardcopy *) ;
EQ : (* Report 4010 Status *) ;
'I' : Begin (* I cases *)
If ReadMchar(abyte) then else goto exit ;
Case chr(abyte) of
'A' : { set pick Aperture } ;
'C' : { set GIN Cursor } ;
'D' : { Disable GIN }
GINenable := False ;
'E' : Begin { Enable GIN }
write(chr(bel));
GINenable := True ;
GIN ;
End ; { Enable GIN }
'F' : Begin { Set GIN stroke Filtering }
DevFunCode := GetInteger ;
DistanceFilter := GetInteger ;
TimeFilter := GetInteger ;
End ; { Set GIN stroke Filtering }
'G' : { Set GIN Gridding } ;
'I' : { Set GIN Inking } ;
'L' : { Set report max Line length } ;
'M' : { set report EOM frequency } ;
'P' : { report GIN point } ;
'Q' : { report Terminal settings } ;
'R' : { set GIN rubberbanding } ;
'S' : { set report signature characters } ;
'V' : { set GIN area } ;
'W' : { set GIN Window } ;
'X' : { set GIN display start Point } ;
end ; (* I sub cases *)
End ; (* I cases *)
'J' : Begin (* J cases *)
If ReadMchar(abyte) then else goto exit ;
Case chr(abyte) of
'C' : { Copy } ;
'Q' : { report device status } ;
end ; (* J subcases *)
End ; (* J cases *)
'K' : Begin (* K cases *)
If ReadMchar(abyte) then else goto exit ;
Case chr(abyte) of
'A' : Begin { enable dialog area }
DAenable := (GetInteger = 1) ;
End ; { enable dialog area }
'B' : { set tab stops } ;
'C' : { cancel } ;
'D' : { define macro } ;
'E' : { set echo } ;
'F' : { lfcr } ;
'H' : { hardcopy } ;
'I' : { ignore deletes } ;
'L' : { lock keyboard } ;
'N' : Begin { renew view }
ViewNumber := GetInteger ;
ClearDevice ;
End ; { renew view }
'O' : { define nonvolatile macro } ;
'Q' : { report errors } ;
'R' : { crlf } ;
'S' : { set snoopy mode } ;
'T' : Begin { set error threshold }
ErrorLevel := GetInteger ; (* valid values 0-4 *)
End ; { set error threshold }
'U' : { save nonvolatile parameters } ;
'V' : { reset } ;
'W' : { enable keyboard expansion } ;
'X' : { expand macro } ;
'Y' : { set key execte character } ;
'Z' : { set edit characters } ;
end ; (* K subcases *)
End ; (* K cases *)
'L' : Begin (* L cases *)
If ReadMchar(abyte) then else goto exit ;
Case chr(abyte) of
'B' : { set dialog area buffer size } ;
'E' : Begin { End Panel }
Line ( Round(LastX * Xscale),Round(LastY * Yscale),
Round(BeginPanelX * Xscale),
Round(BeginPanelY * Yscale) );
FillPoly(Pi,PolyGon) ;
BeginPanel := False ;
End ; { End panel }
'F' : Begin { Move }
If ReadMchar(abyte) then else goto exit;
GetCoord(X1,Y1);
LastX := X1 * (4096 div windowx) ;
LastY := Ysize - (Y1 * (4096 div windowY)) ;
End ; { Move }
'G' : Begin { draw }
If ReadMchar(abyte) then else goto exit;
GetCoord(X1,Y1);
NewX := X1 * (4096 div windowx) ;
NewY := Ysize - (Y1 * (4096 div windowy )) ;
Line ( Round(LastX * Xscale),Round(LastY * Yscale),
Round(NewX * Xscale),Round(NewY * Yscale) ) ;
LastX := NewX;
LastY := NewY;
End ; { draw }
'H' : { draw marker } ;
'I' : { set dialog area index } ;
'L' : Begin { set dialog area lines }
DAlines := GetInteger ;
End ; { set dialog area lines }
'M' : { set dialog area write mode } ;
'P' : Begin { begin panel boundary }
BeginPanel := True ;
If ReadMchar(abyte) then else goto exit;
GetCoord(X1,Y1); { first point }
BeginPanelX := X1 * (4096 div windowx) ;
BeginPanelY := Ysize - (Y1 * (4096 div windowY)) ;
LastX := BeginPanelX ;
LastY := BeginPanelY ;
Boundfillpat := GetInteger = 0 { use fill pattern }
; { else Use current line style }
PI := 1 ;
PolyGon[pi].X := Round(BeginPanelX * xscale );
PolyGon[pi].Y := Round(BeginPanelY * yscale );
End ; { begin panel boundary }
'T' : Begin { graphic text }
AlphaCnt := GetInteger ;
if alphacnt > 255 then alphacnt := 255;
For I := 1 to AlphaCnt do
Begin
If ReadMchar(abyte) then else goto exit;
AlphaStr[I] := chr(abyte);
End;
AlphaStr[0] := Chr(AlphaCnt) ;
OutTextXY(Trunc(LastX*Xscale),
Trunc(LastY*Yscale)-textheight('X'),AlphaStr);
AlphaStr := ' ';
DrawVector := false ;
End ; { graphic text }
'V' : Begin { set dialog area visibility }
If ReadMchar(abyte) then else goto exit;
DAvisibility := abyte = ord('1') ;
End ; { set dialog area visibility }
'Z' : { clear dialog scroll } ;
end ; (* L subcases *)
End ; (* L cases *)
'M' : Begin (* M cases *)
If ReadMchar(abyte) then else goto exit ;
Case chr(abyte) of
'A' : Begin { set graphtext slant }
GTslant := GetInteger ;
End ; { set graphtext slant }
'B' : Begin { set background indices }
GTbackindex := GetInteger ;
GTdashindex := GetInteger ;
End ; { set background indices }
'C' : Begin { set graph text size }
GTwidth := GetInteger ;
GTheight := GetInteger ;
GTspacing := GetInteger ;
SetUserCharSize((GTwidth+GTspacing)*(4096 div windowX),
Round(22400/xdim),GTheight*Round(Ysize/windowY),
Round(20000/ydim));
SetTextStyle(SmallFont,0,UserCharSize) ;
End ; { set graph text size }
'F' : Begin { set graph text font }
GTFont := GetInteger ;
End ; { set graph text font }
'G' : Begin { set graphics area writing mode }
GAmode := (GetInteger = 1 ) ;
End ; { set graphics area writing mode }
'I' : Begin { set pick id }
PickId := GetInteger ; (* value 0 to 32767 *)
End ; { set pick id }
'L' : Begin { set line index }
LineIndex := GetInteger ; (* value 0 to 15 *)
if LineIndex > 15 then LineIndex := 15 ;
SetColor(LineIndex);
End ; { set line index }
'M' : Begin { set line marker type }
MarkerNumber := GetInteger ; (* value 0 to 10 *)
End ; { set line marker type }
'N' : Begin { set character path }
GTpath := GetInteger ; (* value 0 to 4 *)
End ; { set character path }
'P' : Begin { select fill pattern }
Fillpattern := GetInteger ; (* value -15 to 174 *)
If Fillpattern < 0 then
SetFillStyle(1,-Fillpattern)
else
SetFillStyle(Fillpattern,1);
End ; { select fill pattern }
'Q' : Begin { set graph text precision }
GTprecision := GetInteger ; (* value 1 or 2 *)
End ; { set graph text precision }
'R' : Begin { set graph text rotation }
Mantissa := GetInteger ; (* value -32767 to 32767 *)
Exponent := GetInteger ;
(* GTRotation := (Mantissa * (2 ** Exponent); *)
End ; { set graph text rotation }
'S' : Begin { UNKNOWN }
Unknown1 := GetInteger ;
Unknown2 := GetInteger ;
Unknown3 := GetInteger ;
End ;{ UNKNOWN }
'T' : Begin { set text index }
TextIndex := GetInteger ; (* value 0 to 15 *)
If TextIndex > 15 then TextIndex := 15 ;
SetColor(TextIndex);
End ; { set text index }
'V' : Begin { set line style }
LineStyle := GetInteger ; (* value 0 to 7 *)
If LineStyle > 3 then
SetLineStyle(4,pattern[linestyle and $03],normWidth)
else
SetLineStyle(LineStyle,
pattern[linestyle and $03],normWidth);
End ; { set line style }
end ; (* M subcases *)
End ; (* M cases *)
'N' : Begin (* N cases *)
If ReadMchar(abyte) then else goto exit ;
Case chr(abyte) of
'B' : { set stop bits } ;
'C' : { set eom characters } ;
'D' : { set transmit delay } ;
'E' : { set eof string } ;
'F' : { set flagging mode } ;
'G' : Unknown1 := GetInteger ; { UNKNOWN }
'K' : { set break time } ;
'L' : { set transmit limit } ;
'M' : { prompt mode } ;
'P' : { set parity } ;
'Q' : { set queue size } ;
'R' : { set baud rates } ;
'S' : { set prompt string } ;
'T' : { set eol string } ;
'U' : { set bypass cancel character } ;
end ; (* N subcases *)
End ; (* N cases *)
'P' : Begin (* P cases *)
If ReadMchar(abyte) then else goto exit ;
Case chr(abyte) of
'A' : { port assign } ;
'B' : { set port stop bits } ;
'E' : { set port eof string } ;
'F' : { set port flagging mode } ;
'I' : { map index to pen } ;
'L' : { plot } ;
'M' : { set port eol string } ;
'P' : { set port parity } ;
'Q' : { report port status } ;
'R' : { set port baud rate } ;
end ; (* P subcases *)
End ; (* P cases *)
'Q' : Begin (* Q cases *)
If ReadMchar(abyte) then else goto exit ;
Case chr(abyte) of
'A' : { set copy size } ;
'D' : { select hardcopy interface } ;
'L' : { set dialog hardcopy attributes } ;
end ; (* Q subcases *)
End ; (* Q cases *)
'R' : Begin (* R cases *)
If ReadMchar(abyte) then else goto exit ;
Case chr(abyte) of
'A' : { set view attribute } ;
'C' : { select view } ;
'D' : { set surface definitions } ;
'E' : { set border visibility } ;
'F' : Begin { set fixup level }
FixLevel := GetInteger ;
End ; { set fixup level }
'H' : { set pixel beam position } ;
'I' : { set surface visibility } ;
'J' : { lock viewing keys } ;
'K' : Begin { delete view }
ViewNumber := GetInteger ;
End ; { delete view }
'L' : { runlength write } ;
'N' : { set surface priority } ;
'P' : { raster write } ;
'Q' : { set view display cluster } ;
'R' : { rectangle fill } ;
'S' : { set pixel viewport } ;
'U' : Begin { begin pixel operation }
PixSurface := GetInteger ;
ALUmode := GetInteger ;
BitsPerPixel := GetInteger ;
End ; { begin pixel operation }
'V' : Begin { set view port }
If ReadMchar(abyte) then else goto exit;
GetCoord(X1,Y1);
If ReadMchar(abyte) then else goto exit;
GetCoord(X2,Y2) ;
End ; { set view port }
'W' : Begin { set window }
If ReadMchar(abyte) then else goto exit;
GetCoord(X1,Y1);
If ReadMchar(abyte) then else goto exit;
GetCoord(X2,Y2) ;
WindowX := X2-X1;
WindowY := Y2-Y1;
End ; { set window }
'X' : { pixel copy } ;
end ; (* R subcases *)
End ; (* R cases *)
'S' : Begin (* S cases *)
If ReadMchar(abyte) then else goto exit ;
Case chr(abyte) of
'A' : { set segment class } ;
'B' : { begin lower segment }
SegmentNum := SegmentNum - 1 ;
'C' : { end segment } ;
'D' : { set segment detectablity } ;
'E' : Begin { begin new segment }
SegmentNum := GetInteger ;
End ; { begin new segment }
'H' : { set segment highlighting } ;
'I' : { set segment image transform } ;
'K' : Begin { delete segment }
SegmentNum := GetInteger ;
End ; { delete segment }
'L' : { set current matching class } ;
'M' : { set segment writing mode } ;
'N' : { begin higher segment }
SegmentNum := SegmentNum + 1 ;
'O' : Begin { begin segment }
OpenSegment := GetInteger ;
End ; { begin segment }
'P' : { set pivot point } ;
'Q' : { report segment status } ;
'R' : { rename segment } ;
'S' : { set segment display priority } ;
'T' : Begin { begin graphtext character }
If ReadMchar(abyte) then else goto exit;
GTB_FontNumber := GetInteger ;
If ReadMchar(abyte) then else goto exit;
GTB_FontChar := abyte ;
End ; { begin graphtext character }
'U' : { end graphtext character } ;
'V' : { set segment visibilty } ;
'X' : Begin { set segment position }
SegmentNum := GetInteger ;
If ReadMchar(abyte) then else goto exit;
GetCoord(SGPosX,SGPosY);
End ; { set segment position }
end ; (* S subcases *)
End ; (* S cases *)
'T' : Begin (* T cases *)
If ReadMchar(abyte) then else goto exit ;
Case chr(abyte) of
'B' : Begin { set background color }
ColorCoord1 := GetInteger ;
ColorCoord2 := GetInteger ;
ColorCoord3 := GetInteger ;
SetBKcolor(PaletteIndex(HLSColor(ColorCoord1,
ColorCoord2,ColorCoord3))) ;
End ; { set background color }
'C' : Begin { set GIN cursor color }
ColorCoord1 := GetInteger ;
ColorCoord2 := GetInteger ;
ColorCoord3 := GetInteger ;
GINcolor := PaletteIndex(HLSColor(ColorCoord1,
ColorCoord2,ColorCoord3)) ;
End ; { set GIN cursor color }
'D' : { set alpha cursor indices } ;
'F' : { set dialog area color map } ;
'G' : Begin { set surface color map }
(* surfacenumber(-1to4) , numberofintegers (4),
colorindex(0-15),Hue,Lightness,Saturation *)
SurfaceNumber := GetInteger ;
ColorMixI := GetInteger ;
For I := 1 to ColorMixI do
ColorMix[I] := GetInteger ;
I := 1 ;
While I < ColorMixI do
Begin (* Set Color for Colorindex *)
(* ColorMix[I] = ColorIndex *)
(* ColorMix[I+1] = Hue *)
(* ColorMix[I+2] = Lightness *)
(* ColorMix[I+3] = Saturation *)
SetPalette(ColorMix[I],
HLSColor(ColorMix[I+1],ColorMix[I+2],ColorMix[I+3]));
I := I + 4 ;
End ; (* Set Color for Colorindex *)
End ; { set surface color map }
'M' : Begin { set color mode }
ColorMode := GetInteger ;
ColorOverMode := GetInteger ;
GrayMode := GetInteger ;
End ; { set color mode }
end ; (* T subcases *)
End ; (* T cases *)
'`','a','b','c','d','e','f','g','h','i','j','k','l','m','n','o' :
Begin (* Set 4014 Line Style *)
LineStyle := abyte - $60 ; (* value 0 to 15 *)
If LineStyle>7 then LineStyle := LineStyle - 8 ;
If LineStyle > 3 then
SetLineStyle(4,pattern[linestyle and $03],normWidth)
else
SetLineStyle(LineStyle,pattern[linestyle and $03],normWidth);
TEK4014Linestyle := true ;
End ; (* Set 4014 Line Style *)
else
exit :
End ; (* case abyte *)
End ; (* Graphic Escape State *)
(* ================================================================= *)
Begin (* Tektronics Procedure *)
(* delay(9000); add delay to bypass 449 bug *)
TekState := true ;
if lastbyte = 0 then
begin (* TEK4100 color *)
TEK4010 := false ;
Ysize := 4095 ;
Case GraphDriver of
CGA : Graphmode := CGAC0 ;
MCGA : Graphmode := MCGAC0 ;
EGA : Graphmode := EGAHi ;
EGA64 : Graphmode := EGA64Hi ;
EGAMono: Graphmode := EGAMonoHi ;
HercMono : Graphmode := HercMonoHi ;
ATT400 : Graphmode := ATT400C0 ;
VGA : Graphmode := VGALo ;
PC3270 : Graphmode := PC3270Hi ;
End ; (* case *)
end (* TEK4100 color *)
else
begin (* TEK4010 mono *)
abyte := lastbyte ;
Tek4010 := true ;
Ysize := 780 * 4 ;
Case GraphDriver of
CGA : Graphmode := CGAHi ;
MCGA : Graphmode := MCGAHi ;
EGA : Graphmode := EGAHi ;
EGA64 : Graphmode := EGA64Hi ;
EGAMono: Graphmode := EGAMonoHi ;
HercMono : Graphmode := HercMonoHi ;
ATT400 : Graphmode := ATT400Hi ;
VGA : Graphmode := VGAHi ;
PC3270 : Graphmode := PC3270Hi ;
End ; (* case *)
end ; (* TEK4010 mono *)
InitGraph(GraphDriver,GraphMode,' ') ;
result := graphresult ;
if result <> 0 then
begin
writeln(' INIT graph failed ',result);
goto exit ;
end ;
XDim := GetMaxX ;
YDim := GetMaxY ;
WindowX := 4095 ;
WindowY := 4095 ;
XScale := XDim / 4095 ;
YScale := YDim / Ysize ;
(* getmem(SaveScreenP,ImageSize(0,0,Xdim,YDim) ) ; *)
With palette do
Begin (* palette *)
Size := 16 ;
Colors[0] := Black ;
Colors[1] := White ;
Colors[2] := Red ;
Colors[3] := Green ;
Colors[4] := Blue ;
Colors[5] := Cyan ;
Colors[6] := Magenta ;
Colors[7] := Yellow ;
Colors[8] := Brown ;
Colors[9] := LightGreen ;
Colors[10] := LightCyan ;
Colors[11] := LightBlue ;
Colors[12] := LightMagenta ;
Colors[13] := LightRed ;
Colors[14] := DarkGray ;
Colors[15] := LightGray ;
End ;
if tek4010 then (* mono chrome *)
else SetAllPalette(palette) ;
SetTextStyle(SmallFont,0,4) ;
If Newgraph then
begin (* init new graph *)
Newgraph := false ;
WindowX := 4095 ;
WindowY := 4095 ;
XScale := XDim / 4095 ;
YScale := YDim / Ysize ;
CursorX := Xdim div 2 ;
CursorY := Ydim div 2 ;
end (* init new graph *)
else
GraphScreen^ := Savescreen^ ;
(* PutImage(0,0,SaveScreenP^,Normalput) ; *)
HiY := 0; LoY := 0; ExtraY := 0 ;
HiX := 0; LoX := 0; ExtraX := 0 ;
LastX := 0; LastY := 0;
NeedLoY := FALSE ;
DrawVector := FALSE ;
BeginPanel := FALSE ;
AlphaCnt := 0 ;
AlphaStr := '' ;
While TekState Do
Begin (* Tek4100 Emulation *)
If lastbyte = 0 then
If ReadMchar(abyte) then
else goto exit
else lastbyte := 0 ;
Vectormode :
If abyte = GS_ then
Begin (* Vector Mode *)
DrawVector := False ;
VectorContinue :
If ReadMchar(abyte) then else goto exit ;
While not (abyte in [esc,gs_,rs_,us_,fs_,sub,bel,can]) do
Begin (* New coordinates *)
GetCoord(X1,Y1);
NewX := X1 * (4096 div windowx) ;
NewY := Ysize - (Y1 * (4096 div windowY)) ;
(* if Round(NewX * Xscale) > XDim then NewX := 1 ;
if Round(Newy * Yscale) > YDim then NewY := 1 ; *)
IF DrawVector or BeginPanel THEN
Line ( Round(LastX * Xscale),Round(LastY * Yscale),
Round(NewX * Xscale),Round(NewY * Yscale) )
ELSE
DrawVector := TRUE;
LastX := NewX;
LastY := NewY;
If BeginPanel then
Begin { Record Poly Points }
Pi := Pi + 1 ;
PolyGon[pi].x := Round(LastX * Xscale) ;
PolyGon[pi].y := Round(LastY * Yscale) ;
End ; { Record Poly Points }
If ReadMchar(abyte) then else goto exit;
If abyte = gs_ then
Begin
DrawVector := false ;
If ReadMchar(abyte) then else goto exit ;
End ;
End ; (* New Coordinates *)
End ; (* Vector Mode *)
If abyte = ESC then
Begin (* esc sequence *)
TEK4014LineStyle := false ; (* reset tek4014 flag *)
TekEscapeSeq ;
If TEK4014LineStyle then goto VectorContinue ;
End (* esc sequence *)
else
If abyte = FS_ then
Begin (* Marker Mode *)
If ReadMchar(abyte) then else goto exit;
GetCoord(X1,Y1) ;
LastX := X1 * (4096 div windowx) ;
LastY := Ysize - (Y1 * (4096 div windowY)) ;
(* make a mark *)
Mark(Trunc(LastX*Xscale),Trunc(LastY*Yscale),MarkerNumber);
End (* Marker Mode *)
else
If abyte = US_ then
BEGIN {alphamode}
If ReadMchar(abyte) then else goto exit ;
While not (abyte in [esc,gs_,rs_,us_,fs_,ff_,sub,bel,can]) and
(AlphaCnt < 255) do
BEGIN (* get alpha string *)
AlphaStr := alphaStr + chr(abyte);
AlphaCnt := AlphaCnt + 1;
If ReadMchar(abyte) then else goto exit;
END ; (* get alpha string *)
if AlphaCnt > 0 then
OutTextXY(Trunc(LastX*Xscale),
Trunc(LastY*Yscale)-textheight('X'),AlphaStr);
DrawVector := false ;
AlphaCnt := 0 ;
AlphaStr := '' ;
Goto VectorMode ;
END {alphamode}
else
If abyte = BEL then
BEGIN { bell }
writeln(chr(abyte));
Repeat until keypressed ;
achar := readkey ;
TekState := false ;
END { bell }
else
If abyte = FF_ then
BEGIN { Form Feed - New Screen }
ClearDevice ;
sound(2000); delay(1000); nosound ;
END { Form Feed - New Screen }
else
begin
If abyte = GS_ then goto VectorMode ;
If abyte > $20 then outText(chr(abyte))
else
if abyte = $0D then Moveto(0,gety)
else
if abyte = $0A then Moveto(getx,gety+(YDim div 24)) ;
end ;
End ; (* Tek4100 Emulation *)
exit :
CloseGraph ;
End ; (* Tektronics Procedure *)
(* ----------------------------------------------------------------- *)
(* Tek4100 Unit *)
Begin (* tek4100 *)
DetectGraph(GraphDriver,GraphMode);
New(SaveScreen);
If GraphResult = 0 then
Case GraphDriver of
CGA : Begin
Graphmode := CGAHi ;
GraphScreen := PTR($B800,0000);
Graphics := ' - Tek4100 / CGA ';
End ;
MCGA : Begin
Graphmode := MCGAC0 ;
GraphScreen := PTR($A000,0000);
Graphics := ' - Tek4100 / MCGA ';
End ;
EGA : Begin
Graphmode := EGAHi ;
GraphScreen := PTR($A000,0000);
Graphics := ' - Tek4100 / EGA ';
End ;
EGA64 : Begin
Graphmode := EGA64Hi ;
GraphScreen := PTR($A000,0000);
Graphics := ' - Tek4100 / EGA64 ';
End ;
EGAMono: Begin
Graphmode := EGAMonoHi ;
GraphScreen := PTR($A000,0000);
Graphics := ' - Tek4100 / EGAMono ';
End ;
HercMono : Begin
Graphmode := HercMonoHi ;
GraphScreen := PTR($B000,0000);
Graphics := ' - Tek4100 / Hercules ';
End ;
ATT400 : Begin
Graphmode := ATT400C0 ;
GraphScreen := PTR($B800,0000);
Graphics := ' - Tek4100 / AT&T ';
End ;
VGA : Begin
Graphmode := VGAHi ;
GraphScreen := PTR($A000,0000);
Graphics := ' - Tek4100 / VGA ';
End ;
PC3270 : Begin
Graphmode := PC3270Hi ;
GraphScreen := PTR($B800,0000);
Graphics := ' - Tek4100 / PC3270 ';
End ;
End (* case *)
else {From 'If GraphResult = 0'}
begin
Sound (800); delay (50); nosound;
Graphics := 'No graphics';
WriteLn ('No graphic card.');
end;
savescreen := graphscreen ;
End. (* Tek4100 Unit *)