[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]

    {$F+,O+}
    UNIT GAPP2;
    {-----------}INTERFACE{------------}

    USES Graph,crt,dos;

    VAR
       Size,Result: word;
       p: Pointer;
       f: File;
       g : file of word;
       Regs : Registers;
       Count, Count2 : Byte;
       Pal1, Pal2 : Array [0..255, 0..2] of Byte;

    CONST
      Speed1 = 75;

    Procedure FadeOut;
    {This procedure fades out a screen}
    Procedure Fadein;
    {This procedure fades in a screen}
    PROCEDURE StatusBar(x,y,snum,enum : integer);
    {This procedure animates the status bar}
    PROCEDURE Status_Bar(x,y : Integer);
    {Establishes the status bar}
    PROCEDURE Animate_Bar(x,y,Snum,Enum : Integer);
    {a second animation}
    PROCEDURE ReadLnXY(X,Y,t: Integer;VAR S: String;col1,col2: Word);
    {A graphics readln}
    PROCEDURE shadow(x,y : integer;f,s : word;st : string);
    {Shadows the text}
    PROCEDURE frame(x,y,x1,y1 : integer;c1,c2 : word);
    {frames a given area}
    PROCEDURE dobutton(x,y : integer; s : string);
    {draws the button}
    PROCEDURE banimate(x,y : integer; s : string);
    {animates the button}
    FUNCTION CButton(x,y : integer; s : string) : Boolean;
    {checks the button}
    PROCEDURE SaveXY(X1,Y1,X2,Y2: Integer;s : string);
    PROCEDURE showXY(x,y : integer;s : string);
    PROCEDURE erase_file(s : string);
    {Those procedures save, restores a saved screen, or deletes a file}
    {Mouse Functions}
    FUNCTION Mouseinbox(x,y,x1,y1 : integer) : boolean;
    FUNCTION InitMouse : Boolean;
    FUNCTION GetXPosition : Word;
    FUNCTION GetYPosition : Word;
    FUNCTION GetButtonPressed : Byte;
    PROCEDURE ShowMouseCursor;
    PROCEDURE HideMouseCursor;
    PROCEDURE SetMousePosition(X, Y : Word);
    {The following procedures draw a windows like line}
    PROCEDURE Rectangle2(x,y,x1,y1 : Integer);
    PROCEDURE Line2(x,y,x1,y1 : Integer);
    PROCEDURE boxit(x,y : integer; S: String;St : Boolean);

    {-------}IMPLEMENTATION{----------}

    PROCEDURE status_Bar;
    VAR
       x1,y1 : Integer;
    BEGIN
         x1 := x + 306;
         y1 := y + 30;
         Setfillstyle(solidfill,white);
         Bar(x,y,x1,y1);
         Setcolor(Darkgray);
         Line(x,y,x,y1);
         line(x,y,x1,y);
         Setcolor(White);
         line(x,y1,x1,y1);
         line(x1,y,x1,y1);
         Setcolor(Black);
         Line(x+1,y+1,x+1,y1-1);
         line(x+1,y+1,x1-1,y+1);
         Setcolor(Lightgray);
         line(x+1,y1-1,x1-1,y1-1);
         line(x1-1,y+1,x1-1,y1-1);
    END;

    PROCEDURE animate_Bar;
    BEGIN
         Setfillstyle(solidfill,blue);
         bar(x+3,y+3,round(snum / enum * 300)+x+3,y+27);
    END;

    PROCEDURE ReadLnXY;
    VAR
      Ch       : Char;
      Done     : boolean;
      OldX     : Integer;
      limit    : integer;
      refresh,dele : Word;

              procedure prompt;
              begin
                   Moveto(x,y);
                   Outtext('_');
              end;
              procedure del;
              begin
                   Setcolor(dele);
                   Outtext('_');
                   Oldx := getx - textwidth(S[Length(S)]);
                   Moveto(oldx,y);
              end;
              procedure show;
              begin
                   Setcolor(refresh);
                   Outtext('_');
                   Oldx := getx - textwidth(S[Length(S)]);
                   Moveto(oldx,y);
              end;
              Procedure Blink;
              Begin
                   Show;
                   delay(10);
                   del;
                   delay(10)
              end;
    BEGIN
      Settextstyle(font8x8,0,2);
      S := '';
      limit := 0;
      MoveTo(X, Y);
      Dele := Col1;
      Refresh := Col2;
      prompt;
      MoveTo(X, Y);
      Done := False;
      WHILE NOT Done DO
      BEGIN
         While not keypressed do Blink;
         Ch := Readkey;
        CASE Ch of
          #0  : Ch := Readkey;
          #13 : Done := true;
          #27 : Begin
                     S := 'ESCAPE KEY';
                     Done := True;
                End;
          'A'..'Z','a'..'z','0'..'9','.','-':
            BEGIN
              if limit <> 10 then
              begin
                   del;
                   setcolor(Col2);
                   Outtext(ch);
                   show;
                   S := Concat(S, Ch);
                   inc(limit);
              end;
            END;

          #8  : IF Length(S) > 0 THEN
            BEGIN
              del;
              dec(limit);
              OldX := GetX - TextWidth(S[Length(S)]);
              MoveTo(OldX, GetY);
              setcolor(dele);
              OutText('Û');
              SetColor(refresh);
              MoveTo(OldX, GetY);
              Delete(S, Length(S), 1);
              show;
            END;
        END;
      END;
      del;
      setcolor(refresh);
    END;

    PROCEDURE Shadow;
    BEGIN
         SetTextStyle(F,0,S);
         SetColor(Black);
         OutTextXY(x,y,st);
         Outtextxy(x-1,y-1,st);
         Outtextxy(x-2,y-2,st);
         SetColor(White);
         OutTextXY(x+1,y+1,st);
    END;

    PROCEDURE Frame;
    VAR
       I : Integer;
    BEGIN
         FOR I := 0 TO 1 DO
         BEGIN
              setcolor(c1);
              line(x+i,y+i,x+i,y1-i);
              line(x+i,y+i,x1-i,y+i);
              setcolor(C2);
              line(x1-i,y+i,x1-i,y1-i);
              line(x1-i,y1-i,x+i,y1-i);
         END;
         Setcolor(Black);
         Rectangle(x,y,x1,y1);
    END;

    procedure dobutton;
    begin
         setfillstyle(solidfill,blue);
         Settextstyle(7,0,1);
         bar(x-10,y-3,x+5+textwidth(s)+10,y+5+textheight(s)+3);
         frame(x-10,y-3,x+5+textwidth(s)+10,y+5+textheight(s)+3,white,blue);
         Setcolor(Black);
         Outtextxy(x+5,y,s);
         Setcolor(white);
         Outtextxy(x+4,y+1,s);
         Setcolor(black);
         rectangle(x-10,y-3,x+5+textwidth(s)+10,y+5+textheight(s)+3);
    end;

    procedure banimate;
    begin
         hidemousecursor;
         setfillstyle(solidfill,blue);
         bar(x-10,y-3,x+5+textwidth(s)+10,y+5+textheight(s)+3);
         Settextstyle(7,0,1);
         frame(x-10,y-3,x+5+textwidth(s)+10,y+5+textheight(s)+3,darkgray,blue);
         Setcolor(white);
         Outtextxy(x+4,y+1,s);
         Setcolor(black);
         rectangle(x-10,y-3,x+5+textwidth(s)+10,y+5+textheight(s)+3);
         showmousecursor;
         repeat
         until (getbuttonpressed <> 1);
         hidemousecursor;
         dobutton(x,y,s);
         showmousecursor;
    end;

    FUNCTION CButton;
    BEGIN
         Settextstyle(7,0,1);
         CButton := MouseinBox(x-10,y-3,x+5+textwidth(s)+10,y+5+textheight(s)+3);
    END;

    PROCEDURE saveXY;
    BEGIN
         Assign(F,s+'.kis');
         {$I-}
         rewrite(F,1);
         Assign(g,s+'1.kis');
         rewrite(g);
         size := imagesize(x1,y1,x2,y2);
         Write(G,size);
         close(g);
         getmem(P,size);
         getimage(x1,y1,x2,y2,p^);
         Blockwrite(F,P^,Size,result);
         close(f);
         freemem(P,size);
         size := 0;
    END;

    PROCEDURE ShowXY;
    BEGIN
         Assign(F,s+'.kis');
         {$I-}
         reset(F,1);
         Assign(g,s+'1.kis');
         reset(g);
         read(g,size);
         close(g);
         getmem(P,size);
         blockread(F,P^,size,result);
         putimage(x,y,P^,normalput);
         Freemem(P,size);
         close(f);
         size := 0;
    END;

    PROCEDURE erase_file;
    VAR
       q : file;
       r : file of word;
    BEGIN
         assign(q,s+'.kis');
         erase(q);
         assign(r,s + '1.kis');
         erase(r);
    END;

    FUNCTION InitMouse;
    Begin
      Regs.AX := 0;
      Regs.BX := 0;
      Intr($33, Regs);
      InitMouse := (Regs.AX <> 0);
    End;

    PROCEDURE ShowMouseCursor;
    Begin
      Regs.AX := 1;
      Intr($33, Regs);
    End;

    PROCEDURE HideMouseCursor;
    Begin
      Regs.AX := 2;
      Intr($33, Regs);
    End;

    FUNCTION GetXPosition;
    Begin
      Regs.AX := 3;
      Intr($33, Regs);
      GetXPosition := Regs.CX;
    End;

    FUNCTION GetYPosition;
    Begin
      Regs.AX := 3;
      Intr($33, Regs);
      GetYPosition := Regs.DX;
    End;

    FUNCTION GetButtonPressed;
    Begin
      Regs.AX := 3;
      Intr($33, Regs);
      GetButtonPressed := Regs.BX
    End;

    PROCEDURE SetMousePosition;
    Begin
      Regs.AX := 4;
      Regs.CX := X;
      Regs.DX := Y;
      Intr($33, Regs);
    End;

    FUNCTION Mouseinbox;
    begin
         if (getxposition < x1) and (getxposition > x) and (getyposition < y1)
         and (getyposition > y ) then mouseinbox := true
                                 else mouseinbox := false;
    end;

    Procedure Vret;
    VAR b : byte;
    label l1,l2;
    BEGIN
    l1:
         IF port[$3da] and 8 <> 0 THEN goto l1;
    l2 :
         If port[$3da] and 8 <> 0 THEN goto l2;
    End;

    Procedure Getpalette;
    begin
      For Count := 0 to 255 DO
      begin
        PORT [$03C7] := Count;            {Gets colour number}
        Pal1 [Count, 0] := PORT [$03C9];  {Gets red Setting}
        Pal1 [Count, 1] := PORT [$03C9];  {Gets Green Setting}
        Pal1 [Count, 2] := PORT [$03C9];  {Gets Blue Setting}
       end;
      Pal2 := Pal1;
    end;

    Procedure SetPalette;
    begin
      For Count := 0 to 255 DO
      begin
        PORT [$03C8] := Count;           {Sets Colour}
        PORT [$03C9] := Pal1 [Count, 0]; {Sets red}
        PORT [$03C9] := Pal1 [Count, 1]; {Sets Green}
        PORT [$03C9] := Pal1 [Count, 2]; {Sets Blue}
      end;
    end;

    Procedure FadeOut;
    begin
      Getpalette;
      For Count := 1 to Speed1 DO
      begin
        For Count2 := 0 to 255 DO
        begin
          if Pal2 [Count2, 0] > 0 then DEC (Pal2 [Count2, 0]);
          if Pal2 [Count2, 1] > 0 then DEC (Pal2 [Count2, 1]);
          if Pal2 [Count2, 2] > 0 then DEC (Pal2 [Count2, 2]);
          PORT [$03C8] := Count2;
          PORT [$03C9] := Pal2 [Count2, 0];
          PORT [$03C9] := Pal2 [Count2, 1];
          PORT [$03C9] := Pal2 [Count2, 2];
          Vret;
        end;
        delay(5);
      end;
    end;

    Procedure FadeIn;
    begin
      For Count := 1 to Speed1 DO
      begin
        For Count2 := 0 to 255 DO
        begin
          if Pal2 [Count2, 0] < Pal1 [Count2, 0] then INC (Pal2 [Count2, 0]);
          if Pal2 [Count2, 1] < Pal1 [Count2, 1] then INC (Pal2 [Count2, 1]);
          if Pal2 [Count2, 2] < Pal1 [Count2, 2] then INC (Pal2 [Count2, 2]);
          PORT [$03C8] := Count2;
          PORT [$03C9] := Pal2 [Count2, 0];
          PORT [$03C9] := Pal2 [Count2, 1];
          PORT [$03C9] := Pal2 [Count2, 2];
          Vret;
        end;
       delay(5);
      end;
      SetPalette;
    end;

    PROCEDURE rectangle2(x,y,x1,y1 : Integer);
    begin
         Setcolor(Darkgray);
         Line(x,y,x,y1);
         line(x,y,x1,y);
         Setcolor(White);
         line(x,y1,x1,y1);
         line(x1,y,x1,y1);
         Setcolor(Black);
         Line(x+1,y+1,x+1,y1-1);
         line(x+1,y+1,x1-1,y+1);
         Setcolor(Lightgray);
         line(x+1,y1-1,x1-1,y1-1);
         line(x1-1,y+1,x1-1,y1-1);
    end;

    PROCEDURE Line2(x,y,x1,y1 : Integer);
    begin
         Setcolor(Darkgray);
         Line(x,y,x1,y1);
         Setcolor(White);
         Line(x,y+1,x1,y1+1);
    End;

    procedure boxit(x,y : integer; S: String;St : Boolean);
    var
       size : word;
       p : pointer;
    begin
         Case st of
         True :
         begin
              SettextStyle(Font8x8,0,0);
              size := imagesize(x-2,y-2,x+textwidth(S)+2,y+textheight(s)+2);
              getmem(P,size);
              getimage(x-2,y-2,x+textwidth(S)+2,y+textheight(s)+2,P^);
              Setfillstyle(Solidfill,yellow);
              Bar(x-2,y-2,x+textwidth(S),y+textheight(s));
              Setcolor(Black);
              Rectangle(x-2,y-2,x+textwidth(S)+1,y+textheight(s)+1);
              Line(x+textwidth(S)+2,y-1,x+textwidth(S)+2,y+textheight(s)+2);
              Line(x-1,y+textheight(s)+2,x+textwidth(S)+2,y+textheight(s)+2);
              Outtextxy(x,y,S);
         End;
         False :
         begin
              Putimage(X-2,y-2,P^,Normalput);
              Freemem(P,size);
         end;
        end;
    end;

    PROCEDURE StatusBar;
    Var
       per : Longint;
       perc : string;
       done : boolean;

       procedure inits;
       begin
            setfillstyle(solidfill,15);
            bar(x+4,y+4,x+303,y+28);
            done := true;
       end;
    BEGIN
         if not done then inits;
         per := round(snum  / enum * 100);
         setfillstyle(solidfill,white);
         bar(x+per*3+3,y+3,x+303,y+27);
         setfillstyle(solidfill,LightBlue);
         bar(x+3,y+3,x+3 + per * 3 ,y+27);
         str(per,perc);
         Settextstyle(font8x8,0,0);
         If Per > 20 then
         BEgin
              Setcolor(White);
              Outtextxy(x + round(Per*1.4) ,y + 12,perc);
              Outtextxy(x + round(per*1.4+20),y+ 12,' %');
         End;
    END;

    END.

[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]