home *** CD-ROM | disk | FTP | other *** search
/ The Equalizer BBS / equalizer-bbs-collection_2004.zip / equalizer-bbs-collection / DEMOSCENE-STUFF / INTRO93.ZIP / GRAPH320.PAS < prev    next >
Pascal/Delphi Source File  |  1993-02-27  |  16KB  |  535 lines
  1. {$I-}{$F+}
  2. UNIT Graph320;
  3.  
  4. INTERFACE
  5. Uses Dos,TPCrt,MouseLib,TpString;
  6.  
  7. Const
  8.  ConvertTrue : Boolean = True;
  9.  GetFBoxX    : Byte = 100;
  10.  GetFBoxY    : Byte = 60;
  11.  MenuColor   : Byte = 23;
  12.  Reverse     : Boolean = False;
  13.  Mask        : String = '*.UBF';
  14.  MaskType    : Array[1..6] of String = ('*.GIF','*.RAW','*.IVP',
  15.                                         '*.FNT','*.UBF','*.PAL');
  16. Type
  17.   PalArray   = Array[0..767] of Byte;
  18.   DACArray   = Array[0..2] of Byte;
  19.  
  20. Procedure WriteFont(X,Y : Word; Textt : String);
  21. Procedure MakeBeep;
  22. Procedure GetFileName (Var CurrentPath,FileName : String; Action : Byte);
  23. Procedure FillBox(X1,X2,Y1,Y2:Word);
  24. Procedure EraseBox(X1,X2,Y1,Y2:Word);
  25. Procedure FadeInPal(Source : PalArray ; Var Destination : PalArray);
  26. Procedure SetPal(source : PalArray);
  27. Procedure SetColor(A,B,C,D : Byte);
  28. Procedure ErasePal (Var Source : PalArray);
  29. Function FindNearColor (Source : PalArray ; DAColor : DacArray) : Byte;
  30. Procedure WaitKey;
  31.  
  32. IMPLEMENTATION
  33.  
  34. Procedure Font; External; {$L FONTCHAR.OBJ}
  35.  
  36. (********************************************************************)
  37.  
  38. Procedure WriteFont(X,Y : Word; Textt : String);
  39.  
  40. Const
  41.  FontTrans : String[99] = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890?!+-()/.,'':;ç_abcdefghijklmnopqrstuvwxyz=*#$%^&[]{}<>"`~\Çüéâ'
  42.  +'ä ';
  43.  
  44. Var
  45.   TrueNumber : Byte;
  46.   I,I1,I2    : Byte;
  47.  
  48. Begin
  49.   Inc(Y);
  50.   For I := 1 to Length(Textt) do
  51.   Begin
  52.    TrueNumber:=Ord(Textt[I]);
  53.    If ConvertTrue=True then
  54.     Begin
  55.      TrueNumber:=Pos(Textt[I],FontTrans);
  56.      If TrueNumber=0 then TrueNumber:=99;
  57.     End;
  58.    Dec(I);
  59.    Dec(TrueNumber);
  60.    If Reverse=False then
  61.     For I1 := 0 to 4 do
  62.      For I2 := 0 to 5 do
  63.       Mem[$A000:(X+I2+(I*6)+((Y+I1)*320))]:=Mem[Seg(@Font^):(Ofs(@Font^)+(I2*5)+I1+(TrueNumber*30))]
  64.    Else
  65.     For I1 := 0 to 4 do
  66.      For I2 := 0 to 5 do
  67.       Mem[$A000:(X+I2+I*6+((Y+I1)*320))]:=Not Mem[Seg(@Font^):(Ofs(@Font^)+I2*5+I1+TrueNumber*30)];
  68.     Inc(I);
  69.   End;
  70. End;
  71.  
  72. (**********************************************************************)
  73.  
  74. Procedure MakeBeep;
  75.  
  76. Begin
  77.  Sound(5000);
  78.  Delay (10);
  79.  NoSound;
  80. End;
  81.  
  82.  
  83. (**********************************************************************)
  84.  
  85. Function CheckFileChar (Ch : Char) : Boolean;
  86.  
  87.  Const
  88.   FileTable : String = ('ABCDEFGHIJKLMNOPQRSTUVWXYZ.?*!@#$%^&*()-_+[]:\1234567890');
  89.  
  90. Begin
  91.  If Pos(Ch,FileTable)>0 then CheckFileChar:=True Else CheckFileChar:=False;
  92. End;
  93.  
  94. (**********************************************************************)
  95.  
  96. Procedure FillBox(X1,X2,Y1,Y2:Word);
  97.  
  98. Var
  99.   I,I1 : Integer;
  100.  
  101. Begin
  102.   For I := X1 to X2 do For I1 := Y1 to Y2 do
  103.    If Mem[$A000:I+I1*320] = 0 then Mem[$A000:I+I1*320] := 255
  104.    Else Mem[$A000:I+I1*320] := 0;
  105. End;
  106.  
  107. Procedure FILEBOX1; External; {$L FILEBOX.OBJ}
  108.  
  109. (**********************************************************************)
  110.  
  111. Procedure GetFileName (Var CurrentPath,FileName : String; Action : Byte);
  112.  {- Get File Name from the Defined Masks }
  113.  {   Mode: 01 - Load'}
  114.  {         02 - Save'}
  115.  
  116.  
  117.  Var
  118.   WriteFileTest         : File;
  119.   KeyMode               : Boolean;
  120.   Behind                : Array [1..91,1..195] of Byte;
  121.   DirInfo               : Array [1..512] of SearchRec;
  122.   DirInfo1              : SearchRec;
  123.   X1,Y1,pos,Pos1,OldPos : Word;
  124.   Ch                    : Char;
  125.   S                     : String;
  126.   Drive                 : Byte;
  127.   W,MouseX,MouseY,MX,MY : Word;
  128.   ReadList,Bool1        : Boolean;
  129.   ListSize              : Word;
  130.   Real1,Real2           : Real;
  131.   ChangeMask            : Boolean;
  132.   IO                    : Integer;
  133.  
  134. Begin
  135.  ChangeMask:=True;
  136.  OldPos:=0;
  137.  Bool1:=False;
  138.  pos:=1;Pos1:=1;
  139.  ReadList:=True;
  140.  Ch:=#0;
  141.   HideMouseCursor;
  142.   For Y1:=1 to 91 do
  143.    Move(Mem[$A000:((GetFBoxY+Y1-1)*320)+(GetFBoxX)],Behind[Y1,1],195);
  144.   For Y1:=1 to 91 do
  145.    Move(Mem[Seg(@FILEBOX1^):Ofs(@FILEBOX1^)+((Y1-1)*195)],Mem[$A000:((GetFBoxY+Y1-1)*320)+(GetFBoxX)],195); 
  146.    Chdir (CurrentPath);
  147.    Getdir(0,CurrentPath);
  148.    CurrentPath:=CurrentPath+Mask;
  149.   ShowMouseCursor;
  150.   KeyMode:=False;
  151.   Repeat
  152.    HideMouseCursor;
  153.    If Action=1 then S:='Load File' Else S:='Save File';
  154.    WriteFont (GetFBoxX+20,GetFBoxY+2,S);
  155.    If Not KeyMode Then
  156.     Begin
  157.      Drive:=Ord(CurrentPath[1])-64;
  158.      For W:=1 to 5 do
  159.       If Drive=W then WriteFont(GetFBoxX+42,GetFBoxY+25+(W*8),'~') else
  160.        WriteFont(GetFBoxX+42,GetFBoxY+25+(W*8),'`');
  161.      For W:=1 to 6 do
  162.       if Mask=MaskType[W] then WriteFont(GetFBoxX+7,GetFBoxY+25+(W*8),'~') else
  163.        WriteFont(GetFBoxX+7,GetFBoxY+25+(W*8),'`');
  164.      If ChangeMask then
  165.       Begin
  166.        GetDir(Drive,CurrentPath);
  167.        CurrentPath:=AddBackSlash(CurrentPath);
  168.        CurrentPath:=CurrentPath+Mask;
  169.       End
  170.      Else
  171.       Begin
  172.        S:=JustFileName(CurrentPath);
  173.        GetDir(Drive,CurrentPath);
  174.        CurrentPath:=AddBackSlash(CurrentPath);
  175.        CurrentPath:=CurrentPath+S;
  176.       End;
  177.     End;
  178.   WriteFont (GetFBoxX+38,GetFBoxY+12,Copy(Pad(CurrentPath,25),Length(Pad(CurrentPath,25))-24,25));
  179.    If ReadList=True then
  180.     Begin
  181.      ReadList:=False;
  182.      ListSize:=1;
  183.      FindFirst('*.*', $10 , DirInfo1);
  184.       while DosError = 0 do
  185.        Begin
  186.         If (DirInfo1.Attr=$10) And (DirInfo1.Name<>'.') then
  187.          begin
  188.           DirInfo[ListSize]:=DirInfo1;
  189.           Inc(ListSize);
  190.          End;
  191.         FindNext(DirInfo1);
  192.        End;
  193.      DosError:=0;
  194.      FindFirst(CurrentPath, $20 , DirInfo1);
  195.       while DosError = 0 do
  196.        Begin
  197.         DirInfo[ListSize]:=DirInfo1;
  198.         Inc(ListSize);
  199.         FindNext(DirInfo1);
  200.        End;
  201.     End;
  202.    For W:=1 to 7 do
  203.     If (W+Pos1-Pos)<ListSize then
  204.      Begin
  205.       S:=Pad(DirInfo[W+Pos1-pos].Name,12);
  206.       If (pos)=W then Reverse:=True;
  207.       WriteFont(GetFBoxX+62,GetFBoxY+25+(W*8),S);
  208.       Reverse:=False;
  209.      End
  210.     Else
  211.      WriteFont(GetFBoxX+62,GetFBoxY+25+(W*8),'            ');
  212.    If OldPos<>Pos1 then
  213.     Begin
  214.      OldPos:=Pos1;
  215.      W:=ListSize; If W=1 then W:=2;
  216.      Real1:=27/(W-1);
  217.      If (W=1) or (W=2) then Real1:=1;
  218.      EraseBox (GetFBoxX+135,GetFBoxX+147,GetFBoxY+42,GetFBoxY+78);
  219.      FillBox (GetFBoxX+135,GetFBoxX+147,GetFBoxY+41+Trunc(Real1*Pos1),GetFBoxY+51+Trunc(Real1*Pos1));
  220.     End;
  221.    Reverse:=False;
  222.    ShowMouseCursor;
  223.    Repeat until (Keypressed = True) or (Buttonpressed = True);
  224.     If (GetButton(0)=ButtonDown) or (GetButton(1)=ButtonDown) then
  225.     Begin
  226.       MouseX := GetMouseX div 2;
  227.       MouseY := GetMouseY;
  228.       If MouseX>GetFBoxX then MouseX:=MouseX-GetFBoxX else MouseX:=321;
  229.       If MouseY>GetFBoxY then MouseY:=MouseY-GetFBoxY else MouseY:=201;
  230.       If (MouseX >= 0) and (MouseX <= 10) and (MouseY >= 0) and (MouseY <=  10) then
  231.        Begin
  232.         Repeat Until (ButtonReleases(0)>0);
  233.         MouseX := GetMouseX div 2-MouseX;
  234.         MouseY := GetMouseY-MouseY;
  235.         If (MouseX>320) then MouseX:=0 else
  236.          If (MouseX+195>320) then MouseX:=320-195;
  237.         If (MouseY>200) then MouseY:=0 else
  238.          If (MouseY+91>200) then MouseY:=200-91;
  239.          If (MouseX<>GetFBoxX) or (MouseY<>GetFBoxY) then
  240.           Begin
  241.            HideMouseCursor;
  242.            For Y1:=1 to 91 do
  243.             Move(Behind[Y1,1],Mem[$A000:((GetFBoxY+Y1-1)*320)+(GetFBoxX)],195);
  244.             GetFBoxX := MouseX;
  245.             GetFBoxY := MouseY;
  246.            For Y1:=1 to 91 do
  247.             Move(Mem[$A000:((GetFBoxY+Y1-1)*320)+(GetFBoxX)],Behind[Y1,1],195);
  248.             For Y1:=1 to 91 do
  249.              Move(Mem[Seg(@FILEBOX1^):Ofs(@FILEBOX1^)+((Y1-1)*195)],Mem[$A000:((GetFBoxY+Y1-1)*320)+(GetFBoxX)],195);
  250.             OldPos:=0;
  251.            ShowMouseCursor;
  252.           End;
  253.        End;
  254.     If (MouseX >= 1)  and (MouseX <= 38) and (MouseY >= 33) and (MouseY <= 79) then
  255.       Begin Mask:=MaskType[((MouseY-32) DIV 8)+1]; ReadList:=True; ChangeMask:=True; End;
  256.     If (MouseX >= 135)  and (MouseX <= 147) and (MouseY >= 80) and (MouseY <= 89) then
  257.       Begin
  258.        If Pos1<ListSize-1 then
  259.         Begin
  260.          Inc(Pos1);
  261.           If pos<7 then Inc(Pos);
  262.         End;
  263.       End;
  264.     If (MouseX >= 135)  and (MouseX <= 147) and (MouseY >= 31) and (MouseY <= 40) then
  265.       Begin
  266.        If Pos1>1 then
  267.         Begin
  268.          Dec(Pos1);
  269.           If Pos>1 then Dec(Pos);
  270.         End;
  271.       End;
  272.     If ButtonReleases(0)>0 then
  273.      Begin
  274.       If (MouseX >= 1) and (MouseX <=191) and (MouseY >= 12) and (MouseY <= 22) then
  275.        KeyMode:=True;
  276.       If (MouseX >= 151) and (MouseX <= 191) and (MouseY >= 68) and (MouseY <=  76) then
  277.        Begin FillBox(151+GetFBoxX,191+GetFBoxX,68+GetFBoxY,76+GetFBoxY); Ch := Chr(27); FileName:=''; End;
  278.       If (MouseX >= 40)  and (MouseX <= 58) and (MouseY >= 33) and (MouseY <= 71) then
  279.        Begin
  280.         Drive:=((MouseY-32) DIV 8)+1;
  281.         GetDir (Drive,CurrentPath);
  282.         Chdir (CurrentPath);
  283.         ReadList:=True;
  284.         OldPos:=0;
  285.         Pos:=1;Pos1:=1;
  286.        End;
  287.       If (MouseX >= 151)  and (MouseX <= 191) and (MouseY >= 32) and (MouseY <= 40) then
  288.        Begin
  289.         If DirInfo[Pos1].Attr=$20 then
  290.          Begin
  291.           Ch:=#27;
  292.           FileName:=DirInfo[Pos1].Name;
  293.          End
  294.         Else
  295.          Begin MouseX:=60;MouseY:=25+(Pos*8); Bool1:=True; End;
  296.        End;
  297.       If (MouseX >= 151)  and (MouseX <= 191) and (MouseY >= 50) and (MouseY <= 58) then
  298.        Begin
  299.         If DirInfo[Pos1].Attr=$20 then
  300.          Begin
  301.           Ch:=#27;
  302.           FileName:='VIEW:'+DirInfo[Pos1].Name;
  303.          End
  304.        End;
  305.      If (MouseX >= 60)  and (MouseX <= 133) and (MouseY >= 33) and (MouseY <= 88) then
  306.       If Bool1=True then
  307.        Begin
  308.         Bool1:=False;
  309.         if Pos=(((MouseY-32) DIV 8)+1) then
  310.           If DirInfo[Pos1].Attr=Directory then
  311.            Begin
  312.             ReadList:=True;
  313.             Chdir (DirInfo[Pos1].Name);
  314.             Pos1:=1;Pos:=1;OldPos:=0;
  315.            End;
  316.        End;
  317.      End;
  318.      If (MouseX >= 60)  and (MouseX <= 133) and (MouseY >= 33) and (MouseY <= 87) then
  319.       If ListSize>(Pos1-Pos+((MouseY-32) DIV 8)+1) then
  320.        If ReadList=False then
  321.         Begin
  322.          Pos1:=Pos1-Pos;
  323.          Pos:=((MouseY-32) DIV 8)+1;
  324.          Pos1:=Pos1+Pos;
  325.          If Bool1=False then Bool1:=True;
  326.         End;
  327.     End;
  328.    If KeyPressed=True then
  329.     Begin
  330.      Ch:=ReadKey;
  331.      If Ch=#27 then FileName:='';
  332.       If KeyMode=True then
  333.        Begin
  334.         If Ch=#8 then Delete(CurrentPath,Length(CurrentPath),1);
  335.         If Ch=#13 then Begin
  336.                         If Action=1 then
  337.                          Begin
  338.                           ChangeMask:=False;
  339.                           ReadList:=True;
  340.                           KeyMode:=False;
  341.                           Pos:=1;Pos1:=1;OldPos:=0;
  342.                           S:=JustFileName(CurrentPath);
  343.                           CurrentPath:=JustPathName(CurrentPath);
  344.                           CurrentPath:=CleanPathName(CurrentPath);
  345.                           Chdir (CurrentPath);
  346.                           GetDir(0,CurrentPath);
  347.                           CurrentPath:=AddBackSlash(CurrentPath);
  348.                           CurrentPath:=CurrentPath+S;
  349.                          End
  350.                         Else
  351.                          Begin
  352.                           ChangeMask:=False;
  353.                           ReadList:=True;
  354.                           KeyMode:=False;
  355.                           Pos:=1;Pos1:=1;OldPos:=0;
  356.                           S:=JustFileName(CurrentPath);
  357.                           CurrentPath:=JustPathName(CurrentPath);
  358.                           CurrentPath:=CleanPathName(CurrentPath);
  359.                           Chdir (CurrentPath);
  360.                           GetDir(0,CurrentPath);
  361.                           CurrentPath:=AddBackSlash(CurrentPath);
  362.                           CurrentPath:=CurrentPath+S;
  363.                           Assign (WriteFileTest,CurrentPath);
  364.                           Rewrite (WriteFileTest);
  365.                           IO:=IOResult;
  366.                           If IO=0 then
  367.                            Begin
  368.                             Ch:=#27;
  369.                             FileName:=JustFileName(CurrentPath);
  370.                            End;
  371.                           Close(WriteFileTest);
  372.                          End;
  373.                        End;
  374.         Ch:=UpCase(Ch);
  375.         if CheckFileChar(Ch) then
  376.          Begin
  377.           If Length(CurrentPath)<80 then CurrentPath:=CurrentPath+Ch;
  378.           MakeBeep;
  379.          End;
  380.        End;
  381.     End;
  382.   Until Ch=#27;
  383.   HideMouseCursor;
  384.   For Y1:=1 to 91 do
  385.    Move(Behind[Y1,1],Mem[$A000:((GetFBoxY+Y1-1)*320)+(GetFBoxX)],195);
  386.   CurrentPath:=JustPathName(CurrentPath);
  387.   ShowMouseCursor;
  388. End;
  389.  
  390. (**********************************************************************)
  391.  
  392. Procedure EraseBox(X1,X2,Y1,Y2:Word);
  393.  
  394. Var
  395.   I,I1 : Integer;
  396.  
  397. Begin
  398.   For I := X1 to X2 do For I1 := Y1 to Y2 do
  399.    Mem[$A000:I+I1*320] := 0;
  400. End;
  401.  
  402. (**********************************************************************)
  403.  
  404. Procedure FadeInPal(Source : PalArray ; Var Destination : PalArray);
  405.  
  406. Var
  407.   I,I1 : word;
  408. Begin
  409.  For I1:=0 to 63 Do
  410.   Begin
  411.    For I:=0 to 767 do
  412.     If Source[I]>Destination[I] then Inc(Destination[I]) else
  413.      If Source[I]<Destination[I] then Dec(Destination[I]);
  414.    SetPal (Destination);
  415.   End;
  416. End;
  417.  
  418.  (**************************************************************************)
  419.  
  420. Procedure SetPal(Source : PalArray);
  421.  
  422.  Var
  423.    I : Byte;
  424.    Segment,Ofset : Word;
  425.  
  426. Begin
  427.   Segment:=Seg (Source);
  428.   Ofset:=Ofs (Source);
  429.   Asm
  430.       PUSH DS
  431.       MOV AX,Segment
  432.       MOV DS,AX
  433.       MOV CX,$300
  434.       MOV SI,Ofset
  435.       MOV DX,03DAh
  436. @VR2: IN  AL,DX
  437.       TEST AL,08
  438.       JZ @VR2
  439. @VR1: IN  AL,DX
  440.       TEST AL,08
  441.       JNZ @VR1
  442.       MOV DX,$03C8
  443.       XOR AL,AL
  444.       OUT DX,AL
  445.       INC DX
  446.   REP OUTSB
  447.       POP DS
  448.   End;
  449. End;
  450.  
  451.  (**************************************************************************)
  452.  
  453. Procedure SetColor(A,B,C,D : Byte);
  454.  
  455. Begin
  456.   Asm
  457.       MOV DX,03DAh
  458. @VR2: IN  AL,DX
  459.       TEST AL,08
  460.       JZ @VR2
  461. @VR1: IN  AL,DX
  462.       TEST AL,08
  463.       JNZ @VR1
  464.       MOV DX,$03C8
  465.       MOV AL,D
  466.       OUT DX,AL
  467.       INC DX
  468.       MOV AL,A
  469.       OUT DX,AL
  470.       MOV AL,B
  471.       OUT DX,AL
  472.       MOV AL,C
  473.       OUT DX,AL
  474.  End;
  475. End;
  476.  
  477.  (**************************************************************************)
  478.  
  479. Procedure ErasePal (Var Source : PalArray);
  480.  
  481.  Var
  482.    Segment,Ofset : Word;
  483.  
  484. Begin
  485.   Segment:=Seg (Source);
  486.   Ofset:=Ofs (Source);
  487. {$F+}
  488.   Asm
  489.       PUSH ES
  490.       MOV  AX,Segment
  491.       MOV  ES,AX
  492.       MOV  DI,Ofset
  493.       MOV  CX,384
  494.       XOR  AX,AX
  495.       REP  STOSW
  496.       POP  ES
  497.   End;
  498. {$F-}
  499. End;
  500.  
  501.  (**************************************************************************)
  502.  
  503. Function FindNearColor (Source : PalArray ; DAColor : DacArray) : Byte;
  504.  
  505. Var
  506.  I : Byte;
  507.  LastNear,MinSub,CurSub : Byte;
  508.  
  509. Begin
  510.  LastNear:=0;
  511.  MinSub:=255;
  512.  For I:=0 to 255 do
  513.   Begin
  514.    CurSub:=Abs(Source[I*3]-DAColor[0])+Abs(Source[I*3+1]-DAColor[1])+Abs(Source[I*3+2]-DAColor[2]);
  515.    If MinSub>CurSub then
  516.     Begin MinSub:=CurSub; LastNear:=I; End;
  517.   End;
  518.  FindNearColor:=LastNear;
  519. End;
  520.  
  521.  (**************************************************************************)
  522.  
  523. Procedure WaitKey;
  524.  
  525.  Var
  526.   Ch : Char;
  527.  
  528.  Begin
  529.   Ch:=#00;
  530.   Repeat Until (KeyPressed) Or (ButtonPressed);
  531.    If KeyPressed Then Ch:=ReadKey;
  532.    Ch:=#00;
  533.  End;
  534. End.
  535.