(***********************************************************)
(*                                                         *)
(*                  Graphics system kernel                 *)
(*                     fuer BiC 5105                       *)
(*                     Stand: 12.2.89                      *)
(*                                                         *)
(***********************************************************)

const StringSizeGlb=80;
      CharFile:string[StringSizeGlb]='4x6.fon';

type  wrkstring=string[StringSizeGlb];
      character=array [1..3] of byte;
      CharArray=array [32..126] of character;
      LineStyleArray=array [0..7] of boolean;

var   X1RefGlb,X2RefGlb,Y1RefGlb,Y2RefGlb:integer;
      LinestyleGlb:integer;
      DirectModeGlb,ClippingGlb,HatchGlb:boolean;
      CntGlb,ColorGlb:byte;
      ErrCodeGlb:byte;
      LineStyleArrayGlb:LineStyleArray;
      AspectGlb:real;
      CharSet:CharArray;
      XMaxGlb,XScreenMaxGlb:integer;

const YMaxGlb=199;
      AspectFactor=1;

procedure Screen(aktmod, aktpag, vismod, vispag : byte);
begin
INLINE(
$DD/$2A/$3E/$00         {          LD IX,(SPGR)                        }
/$DD/$6E/$1A            {          LD L,(IX+26) ;SLCTRL-Address        }
/$DD/$66/$1B            {          LD H,(IX+27)                        }
/$7E                    {          LD A,(HL)                           }
/$32/*+$0017            {          LD (ANSL),A                         }
/$3A/AKTMOD             {          LD A,(AKTMOD)                       }
/$47                    {          LD B,A ;aktiv mode                  }
/$3A/AKTPAG             {          LD A,(AKTPAG)                       }
/$4F                    {          LD C,A ;aktiv page                  }
/$3A/VISMOD             {          LD A,(VISMOD)                       }
/$57                    {          LD D,A ;visuell mode                }
/$3A/VISPAG             {          LD A,(VISPAG)                       }
/$5F                    {          LD E,A ;visuell page                }
/$CD/*+$0007            {          CALL JPIX                           }
/$5F/$00                { ANADR    DEFW SELSCR                         }
/$00                    { ANSL     DEFB 0                              }
/$18/$02                {          JR ENDSCR                           }
/$DD/$E9                { JPIX     JP (IX)                             }
)
end;

procedure ClearScreen;
begin
INLINE(
$DD/$2A/$3E/$00         {          LD IX,(SPGR)                        }
/$DD/$6E/$1A            {          LD L,(IX+26) ;SLCTRL-Address        }
/$DD/$66/$1B            {          LD H,(IX+27)                        }
/$7E                    {          LD A,(HL)                           }
/$32/*+$0008            {          LD (ANSL),A                         }
/$AF                    {          XOR A                               }
/$CD/*+$0007            {          CALL JPIX                           }
/$C3/$00                {          DEFW ZCLS                           }
/$00                    { ANSL     DEFB 0                              }
/$18/$02                {          JR ENDCLS                           }
/$DD/$E9                { JPIX     JP (IX)                             }
)
end;

procedure dp(x, y : integer);
  label ende;
begin
  y := 199-y; if y <0 then goto ende;
INLINE(
$DD/$2A/$3E/$00         {          LD IX,(SPGR)                        }
/$DD/$6E/$1A            {          LD L,(IX+26) ;SLCTRL-Address        }
/$DD/$66/$1B            {          LD H,(IX+27)                        }
/$7E                    {          LD A,(HL)                           }
/$32/*+$001C            {          LD (ANSL0),A                        }
/$32/*+$0021            {          LD (ANSL1),A                        }
/$32/*+$0027            {          LD (ANSL2),A                        }
/$32/*+$002A            {          LD (ANSL3),A                        }
/$21/X                  {          LD HL,X                             }
/$4E                    {          LD C,(HL)                           }
/$23                    {          INC HL                              }
/$46                    {          LD B,(HL) ;x-Koordinate             }
/$21/Y                  {          LD HL,Y                             }
/$5E                    {          LD E,(HL)                           }
/$23                    {          INC HL                              }
/$56                    {          LD D,(HL) ;y-Koordinate             }
/$CD/*+$001E            {          CALL JPIX                           }
/$0E/$01                {          DEFW TPPOS                          }
/$00                    { ANSL0    DEFB 0                              }
/$30/$19                {          JR NC,ENDPGR                        }
/$CD/*+$0016            {          CALL JPIX                           }
/$11/$01                {          DEFW MKPMA                          }
/$00                    { ANSL1    DEFB 0                              }
/$3A/COLORGLB           {          LD A,(COLORGLB)                     }
/$CD/*+$000D            {          CALL JPIX                           }
/$1A/$01                {          DEFW STAINK                         }
/$00                    { ANSL2    DEFB 0                              }
/$CD/*+$0007            {          CALL JPIX                           }
/$20/$01                {          DEFW SPOINT                         }
/$00                    { ANSL3    DEFB 0                              }
/$18/$02                {          JR ENDPGR                           }
/$DD/$E9                { JPIX     JP (IX)                             }
);
ende:
end;

procedure Graphic_mc;
begin
  Screen(5,0,5,0);
  XMaxGlb:=40;
  XScreenMaxGlb:=319;
end;

procedure Graphic_hr;
begin
  Screen(3,1,3,1);
  XMaxGlb:=80;
  XScreenMaxGlb:=639;
end;

procedure Alpha_scr;
begin
  Screen(1,0,1,0);
end;

procedure init;
begin
  Screen(5,0,1,0);
  ClearScreen;
  Screen(3,1,1,0);
  ClearScreen;
  Graphic_hr;
end;

procedure LeaveGraphic;
begin
  Alpha_scr;
  ClearScreen;
end;

procedure error (ErrProc,ErrCode:integer);
var     datei: file of string [30];
        satz : string [30];
begin
  LeaveGraphic;
  writeln ('TURBO Graphics Fehler');
{$I-}
assign (datei,'TURBO.ERR');
reset  (datei);
{$I+}
  if ioresult <> 0
     then begin
            ErrProc := 28;
            ErrCode :=  8;
          end;

write ('      Procedure: ');
if (ErrProc >= 0) and (ErrProc <= 27)
   then begin
          seek (datei, ErrProc);
          read (datei, satz);
          writeln (satz);
        end
   else writeln (ErrProc:3);

write ('      Code:      ');
if (ErrCode >= 1) and (ErrCode <= 7)
   then begin
          seek (datei, ErrCode+27);
          read (datei, satz);
          writeln (satz);
        end
   else writeln (ErrCode:3);

halt;
close (datei);
end;

procedure SetLinestyle(ls:integer);
  var i:integer;
  const lsa:array [0..4] of byte=($FF,$88,$F8,$E4,$EE);

  begin
    if not (ls in [0..4]) then ls:=ls and $FF + $100;
    LineStyleGlb:=ls;
    if ls<5 then ls:=lsa[ls];
    for i:=0 to 7 do LineStyleArrayGlb[7-i]:=((ls shr i) and 1)<>0;
    CntGlb:=7;
  end;

procedure InitGraphic;
  var fil:text;
      tfile:text;
      test:^integer;
      temp:WrkString;
      i:integer;
      help:array [0..284] of char absolute CharSet;

  begin
    if CharFile<>'' then
     begin
      assign(fil,CharFile);
      {$I-} reset(fil); {$I+}
      if ioresult=0 then for i:=0 to 284 do read(fil,help[i])
      else error(0,1);
      close(fil);
     end;
    init;
    AspectGlb:=AspectFactor*AspectFactor;
    HatchGlb:=false;
    ClippingGlb:=true;
    DirectModeGlb:=false;
    X1RefGlb:=0;
    X2RefGlb:=XMaxGlb;
    Y1RefGlb:=0;
    Y2RefGlb:=YMaxGlb;
    ColorGlb := 1;
    SetLineStyle(0);
    ClearScreen;
  end;

function clip(var x1,y1,x2,y2:integer):boolean;
  var ix1,iy1,ix2,iy2,dummy,x1Loc,x2Loc:integer;
      ClipLoc:boolean;

  function inside(x,xx1,xx2:integer):integer;
     begin
       inside:=0;
       if x<xx1 then inside:=-1
       else if x>xx2 then inside:=1;
     end;

  begin
    clip:=true;
    ClipLoc:=true;
    if ClippingGlb then
     begin
      if HatchGlb then
       begin
        X1Loc:=X1RefGlb;
        X2Loc:=X2RefGlb;
       end
      else
       begin
        X1Loc:=X1RefGlb shl 3;
        X2Loc:=X2RefGlb shl 3 +7;
       end;
      ix1:=inside(x1,X1Loc,X2Loc);
      iy1:=inside(y1,Y1RefGlb,Y2RefGlb);
      ix2:=inside(x2,X1Loc,X2Loc);
      iy2:=inside(y2,Y1RefGlb,Y2RefGlb);
      if (ix1 or ix2 or iy1 or iy2)<>0 then
       begin
        if x1<>x2 then
         begin
          if ix1<>0 then
           begin
            if ix1<0 then dummy:=X1Loc else dummy:=X2Loc;
            if y2<>y1 then y1:=y1+trunc((y2-y1)/(x2-x1)*(dummy-x1));
            x1:=dummy;
           end;
          if (ix2<>0) and (x1<>x2) then
           begin
            if ix2<0 then dummy:=X1Loc else dummy:=X2Loc;
            if y2<>y1 then y2:=y1+trunc((y2-y1)/(x2-x1)*(dummy-x1));
            x2:=dummy;
           end;
          iy1:=inside(y1,Y1RefGlb,Y2RefGlb);
          iy2:=inside(y2,Y1RefGlb,Y2RefGlb);
         end;
        if y1<>y2 then
         begin
          if iy1<>0 then
           begin
            if iy1<0 then dummy:=Y1RefGlb else dummy:=Y2RefGlb;
            if x1<>x2 then x1:=x1+trunc((x2-x1)/(y2-y1)*(dummy-y1));
            y1:=dummy;
           end;
          if iy2<>0 then
           begin
            if iy2<0 then dummy:=Y1RefGlb else dummy:=Y2RefGlb;
            if x1<>x2 then x2:=x1+trunc((x2-x1)/(y2-y1)*(dummy-y1));
            y2:=dummy;
           end;
         end;
        iy1:=inside(y1,Y1RefGlb,Y2RefGlb);
        iy2:=inside(y2,Y1RefGlb,Y2RefGlb);
        if (iy1<>0) or (iy2<>0) then ClipLoc:=false;
        if ClipLoc then
         begin
          ix1:=inside(x1,X1Loc,X2Loc);
          ix2:=inside(x2,X1Loc,X2Loc);
          if (ix2<>0) or (ix1<>0) then ClipLoc:=false;
         end;
        clip:=ClipLoc;
       end;
     end;
  end;

procedure DrawLineDirect(x1,y1,x2,y2:integer);
   var x,y,DeltaX,DeltaY,XStep,YStep,direction:integer;

   begin
      x:=x1;
      y:=y1;
      XStep:=1;
      YStep:=1;
      if x1>x2 then XStep:=-1;
      if y1>y2 then YStep:=-1;
      DeltaX:=abs(x2-x1);
      DeltaY:=abs(y2-y1);
      if DeltaX=0 then direction:=-1
      else direction:=0;
      while not ((x=x2) and (y=y2)) do
       begin
        if LinestyleGlb=0 then dp(x,y)
        else
         begin
          CntGlb:=(CntGlb+1) and 7;
          if LineStyleArrayGlb[CntGlb] then dp(x,y);
         end;
        if direction<0 then
         begin
          y:=y+YStep;
          direction:=direction+DeltaX;
         end
        else
         begin
          x:=x+XStep;
          direction:=direction-DeltaY;
         end;
       end;
  end;

procedure DrawLine(x1,y1,x2,y2:real);
  begin
    DrawLineDirect(trunc(x1),trunc(y1),trunc(x2),trunc(y2));
  end;

procedure DrawLineClipped(x1,y1,x2,y2:integer);
  begin
    if clip(x1,y1,x2,y2) then DrawLine(x1,y1,x2,y2);
  end;

procedure DrawCircleDirect(xr,yr,r:integer; DirectModeLoc: boolean);
  const n=14;
  type Circ = array [1..n] of integer;
  const x:Circ=(0,121,239,355,465,568,663,749,823,885,935,971,993,1000);
  var xk1,xk2,yk1,yk2,xp1,yp1,xp2,yp2:integer;
      xfact,yfact:real;
      i:integer;

  procedure DrawLinW(X1,Y1,X2,Y2:integer);
    var DrawIt: boolean;

    begin
      DrawIt:=DirectModeLoc;
      if not DrawIt then DrawIt:=Clip(X1,Y1,X2,Y2);
      if DrawIt then DrawLine(X1,Y1,X2,Y2);
    end;

  begin
    xfact:=abs(r*0.001);
    yfact:=xfact*AspectGlb;
    if xfact>0.0 then
     begin
      xk1:=trunc(x[1]*xfact+0.5);
      yk1:=trunc(x[n]*yfact+0.5);
      for i:=2 to n do
       begin
        xk2:=trunc(x[i]*xfact+0.5);
        yk2:=trunc(x[n-i+1]*yfact+0.5);
        xp1:=xr-xk1;
        yp1:=yr+yk1;
        xp2:=xr-xk2;
        yp2:=yr+yk2;
        DrawLinW(xp1,yp1,xp2,yp2);
        xp1:=xr+xk1;
        xp2:=xr+xk2;
        DrawLinW(xp1,yp1,xp2,yp2);
        yp1:=yr-yk1;
        yp2:=yr-yk2;
        DrawLinW(xp1,yp1+1,xp2,yp2+1);
        xp1:=xr-xk1;
        xp2:=xr-xk2;
        DrawLinW(xp1,yp1+1,xp2,yp2+1);
        xk1:=xk2;
        yk1:=yk2;
       end;
     end
    else dp(xr,yr);
  end;

procedure DrawAscii(var x,y:integer;
                    size,ch:byte);
  var x1ref,x2ref,xpos,ypos,xstart,ystart,xend,yend,xx,yy: integer;
      charbyte: byte;

  begin
    x1ref:=X1RefGlb shl 3;
    x2ref:=X2RefGlb shl 3+7;
    for ypos:=0 to 5 do
     begin
      CharByte:=(CharSet[ch,(7-ypos) shr 1] shr ((ypos and 1) shl 2)) and $0F;
      for xpos:=0 to 3 do
        if (CharByte shr (3-xpos)) and 1<>0 then
         begin
          xstart:=x+xpos*size;
          xend:=xstart+size-1;
          ystart:=y+1+(ypos-2)*size;
          yend:=ystart+size-1;
          if ClippingGlb then
           begin
            if xstart<x1ref then xstart:=x1ref;
            if xend>x2ref then xend:=x2ref;
            if ystart<Y1RefGlb then ystart:=Y1RefGlb;
            if yend>Y2RefGlb then yend:=Y2RefGlb;
           end;
          for yy:=ystart to yend do
            for xx:=xstart to xend do
              dp(xx,yy);
         end;
     end;
     x:=x+size*6;
   end;

procedure DrawText(x,y,scale:integer;
                   txt:wrkstring);
  var LineStyleLoc,code,AsciiValue,StringLen,i,SymbolScale,SymbolCode:integer;
      DirectModeLoc:boolean;

  begin
    DirectModeLoc:=DirectModeGlb;
    DirectModeGlb:=true;
    LineStyleLoc:=LinestyleGlb;
    SetLineStyle(0);
    StringLen:=length(txt);
    i:=1;
    while i<=StringLen do
     begin
      AsciiValue:=ord(txt[i]);
      if AsciiValue>27 then DrawAscii(x,y,scale,AsciiValue);
      i:=i+1;
     end;
    DirectModeGlb:=DirectModeLoc;
    SetLineStyle(LineStyleLoc);
  end;

procedure hardcopy(inverse:boolean;mode:byte); { EPSON }
  begin
  end;