home *** CD-ROM | disk | FTP | other *** search
/ World of Shareware - Software Farm 2 / wosw_2.zip / wosw_2 / PASCAL / SORTDEMO.ZIP / SDGRAF.INC < prev    next >
Text File  |  1992-04-15  |  10KB  |  281 lines
  1. (*
  2. ╔═══════════════════════════════════════════════════════════════════════════╗
  3. ║ Turbo Pascal 6.0 Include File : SDGRAF.INC                                ║
  4. ╟───────────────────────────────────────────────────────────────────────────╢
  5. ║ Program : SORTDEMO.PAS                                                    ║
  6. ╟───────────────────────────────────────────────────────────────────────────╢
  7. ║ Version : 1.0                                                             ║
  8. ╟───────────────────────────────────────────────────────────────────────────╢
  9. ║ Copyright (c) 1992  by  Jon S. Russell                                    ║
  10. ╟───────────────────────────────────────────────────────────────────────────╢
  11. ║ Basic graphics routines for SORTDEMO.PAS                                  ║
  12. ╚═══════════════════════════════════════════════════════════════════════════╝
  13.                                                                            *)
  14.  
  15. {$F+  force far calls on  }
  16. function DetectVGA256 : integer;
  17. var
  18.  DetectedDriver : integer;
  19.  SuggestedMode  : integer;
  20.  
  21. begin (* DetectVGA256 *)
  22.   DetectGraph(DetectedDriver, SuggestedMode);
  23.   if ((DetectedDriver = VGA) or (DetectedDriver = MCGA))
  24.     then DetectVGA256 := 0
  25.     else DetectVGA256 := grError;
  26. end;  (* DetectVGA256 *)
  27. {$F-  force far calls off }
  28.  
  29. (*─────────────────────────────────────────────────────────────────────────*)
  30.  
  31. procedure InitMode13h;
  32. var
  33.   PathToDriver  : string;
  34.   grDriver      : integer;
  35.   grMode        : integer;
  36.   AutoDetectPtr : pointer;
  37.   ErrorCode     : integer;
  38.  
  39. begin  (* InitMode13h *)
  40.   DirectVideo := false;  (* allow writeln in graphics mode *)
  41.   PathToDriver := '';
  42.   repeat
  43.     AutoDetectPtr := @DetectVGA256;
  44.     grDriver := InstallUserDriver('VGA256', AutoDetectPtr);
  45.     grDriver := Detect;
  46.     InitGraph(grDriver, grMode, PathToDriver);
  47.     ErrorCode := GraphResult;
  48.     if (ErrorCode <> grOk) then
  49.       begin
  50.         writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
  51.         if (ErrorCode = grFileNotFound)
  52.           then
  53.             begin
  54.               writeln('Enter full path or type <Ctrl-Break> to quit:');
  55.               readln(PathToDriver);
  56.               writeln;
  57.             end
  58.           else
  59.             begin
  60.               writeln('Program terminated.');
  61.               Halt(1);
  62.             end;
  63.       end; (* ErrorCode <> grOk *)
  64.   until (ErrorCode = grOk);
  65. end;   (* InitMode13h *)
  66.  
  67. (*─────────────────────────────────────────────────────────────────────────*)
  68.  
  69. procedure InitFonts;
  70. begin  (* InitFonts *)
  71.   if RegisterBGIFont(@SmallFontProc) < 0 then
  72.     begin
  73.       writeln('Error registering font: ', GraphErrorMsg(GraphResult));
  74.       Halt(1);
  75.     end;
  76.   SetTextStyle(SmallFont, HorizDir, 4);
  77. end;   (* InitFonts *)
  78.  
  79. (*─────────────────────────────────────────────────────────────────────────*)
  80.  
  81. procedure GetRGBPalette (var Pal : PaletteType);
  82. var
  83.   Regs : Registers;
  84.  
  85. begin  (* GetRGBPalette *)
  86.   with Regs do
  87.     begin
  88.       AX := $1017;
  89.       BX := 0;        (* start at color 0 *)
  90.       CX := 256;      (* repeat for 256 colors *)
  91.       ES := Seg(Pal);
  92.       DX := Ofs(Pal);
  93.     end;
  94.   Intr($10, Regs);
  95. end;   (* GetRGBPalette *)
  96.  
  97. (*─────────────────────────────────────────────────────────────────────────*)
  98.  
  99. procedure SetRGBPalette (var Pal : PaletteType);
  100. var
  101.   Regs : Registers;
  102.  
  103. begin  (* SetRGBPalette *)
  104.   with Regs do
  105.     begin
  106.       AX := $1012;
  107.       BX := 0;        (* start at color 0 *)
  108.       CX := 256;      (* repeat for 256 colors *)
  109.       ES := Seg(Pal);
  110.       DX := Ofs(Pal);
  111.     end;
  112.   Intr($10, Regs);
  113. end;   (* SetRGBPalette *)
  114.  
  115. (*─────────────────────────────────────────────────────────────────────────*)
  116.  
  117. procedure InitPalettes (var DefaultPalette : PaletteType;
  118.                         var Palette        : PaletteType);
  119. var
  120.   i : byte;
  121.  
  122. begin  (* InitPalettes *)
  123.   GetRGBPalette(DefaultPalette);  (* save the default palette *)
  124.   Palette := DefaultPalette;      (* start with default then modify *)
  125.  
  126.   (* modify colors 0 & 32..71, (40 colors) *)
  127.  
  128.   Palette[0].Red := 8;
  129.   Palette[0].Grn := 8;
  130.   Palette[0].Blu := 8;
  131.  
  132.   with Palette[32] do begin  Red:=20; Grn:= 0; Blu:= 0;  end;
  133.   with Palette[33] do begin  Red:=30; Grn:= 0; Blu:= 0;  end;
  134.   with Palette[34] do begin  Red:=40; Grn:= 0; Blu:= 0;  end;
  135.   with Palette[35] do begin  Red:=50; Grn:= 0; Blu:= 0;  end;
  136.   with Palette[36] do begin  Red:=60; Grn:= 0; Blu:= 0;  end;
  137.   with Palette[37] do begin  Red:=60; Grn:= 0; Blu:=30;  end;
  138.   with Palette[38] do begin  Red:=60; Grn:= 0; Blu:=38;  end;
  139.   with Palette[39] do begin  Red:=60; Grn:= 0; Blu:=45;  end;
  140.   with Palette[40] do begin  Red:=60; Grn:= 0; Blu:=52;  end;
  141.   with Palette[41] do begin  Red:=60; Grn:= 0; Blu:=60;  end;
  142.   with Palette[42] do begin  Red:=50; Grn:= 0; Blu:=60;  end;
  143.   with Palette[43] do begin  Red:=40; Grn:= 0; Blu:=60;  end;
  144.   with Palette[44] do begin  Red:=30; Grn:= 0; Blu:=60;  end;
  145.   with Palette[45] do begin  Red:=20; Grn:= 0; Blu:=60;  end;
  146.   with Palette[46] do begin  Red:=15; Grn:= 0; Blu:=60;  end;
  147.   with Palette[47] do begin  Red:= 0; Grn:= 0; Blu:=60;  end;
  148.   with Palette[48] do begin  Red:= 0; Grn:=20; Blu:=60;  end;
  149.   with Palette[49] do begin  Red:= 0; Grn:=30; Blu:=60;  end;
  150.   with Palette[50] do begin  Red:= 0; Grn:=40; Blu:=60;  end;
  151.   with Palette[51] do begin  Red:= 0; Grn:=50; Blu:=60;  end;
  152.   with Palette[52] do begin  Red:= 0; Grn:=60; Blu:=60;  end;
  153.   with Palette[53] do begin  Red:= 0; Grn:=60; Blu:=50;  end;
  154.   with Palette[54] do begin  Red:= 0; Grn:=60; Blu:=40;  end;
  155.   with Palette[55] do begin  Red:= 0; Grn:=60; Blu:=30;  end;
  156.   with Palette[56] do begin  Red:= 0; Grn:=60; Blu:=20;  end;
  157.   with Palette[57] do begin  Red:= 0; Grn:=60; Blu:= 0;  end;
  158.   with Palette[58] do begin  Red:=30; Grn:=60; Blu:= 0;  end;
  159.   with Palette[59] do begin  Red:=40; Grn:=60; Blu:= 0;  end;
  160.   with Palette[60] do begin  Red:=50; Grn:=60; Blu:= 0;  end;
  161.   with Palette[61] do begin  Red:=60; Grn:=60; Blu:= 0;  end;
  162.   with Palette[62] do begin  Red:=63; Grn:=63; Blu:= 0;  end;
  163.   with Palette[63] do begin  Red:=60; Grn:=50; Blu:= 0;  end;
  164.   with Palette[64] do begin  Red:=60; Grn:=40; Blu:= 0;  end;
  165.   with Palette[65] do begin  Red:=60; Grn:=30; Blu:= 0;  end;
  166.   with Palette[66] do begin  Red:=60; Grn:=20; Blu:= 0;  end;
  167.   with Palette[67] do begin  Red:=50; Grn:=20; Blu:= 0;  end;
  168.   with Palette[68] do begin  Red:=40; Grn:=20; Blu:= 0;  end;
  169.   with Palette[69] do begin  Red:=30; Grn:=20; Blu:= 0;  end;
  170.   with Palette[70] do begin  Red:=25; Grn:=20; Blu:= 0;  end;
  171.   with Palette[71] do begin  Red:=20; Grn:=20; Blu:= 0;  end;
  172.  
  173.   SetRGBPalette(Palette);
  174. end;   (* InitPalettes *)
  175.  
  176. (*─────────────────────────────────────────────────────────────────────────*)
  177.  
  178. procedure DrawPanel (px1, py1, px2, py2    : integer;
  179.                      MainCol, HiCol, LoCol : word;
  180.                      Thick                 : byte);
  181.  
  182. var
  183.   OldFill : FillSettingsType;
  184.   OldCol  : word;
  185.   i       : byte;
  186.  
  187. begin  (* DrawPanel *)
  188.   GetFillSettings(OldFill);
  189.   OldCol := GetColor;
  190.  
  191.   SetFillStyle(SolidFill, MainCol);
  192.   Bar(px1,py1,px2,py2);
  193.   SetColor(HiCol);
  194.  
  195.   for i := 1 to Thick do
  196.     begin
  197.       SetColor(HiCol);
  198.       Line(px1-i, py1-i, px2+i, py1-i);
  199.       Line(px1-i, py1-i, px1-i, py2+i);
  200.       SetColor(LoCol);
  201.       Line(px1-i, py2+i, px2+i, py2+i);
  202.       Line(px2+i, py1-i, px2+i, py2+i);
  203.     end;
  204.  
  205.   SetFillStyle(OldFill.Pattern, OldFill.Color);
  206.   SetColor(OldCol);
  207. end;   (* DrawPanel *)
  208.  
  209. (*─────────────────────────────────────────────────────────────────────────*)
  210.  
  211. procedure LoadArray (var Info : InfoType);
  212. var
  213.   i,r,c : word;
  214.  
  215.   (*───────────────────────────────────────────────────────────────────────*)
  216.  
  217.   function CalcColor (var xElems : word; c : word) : word;
  218.  
  219.     (*─────────────────────────────────────────────────────────────────────*)
  220.  
  221.     function Calc40 (c : word) : word;
  222.     begin (* Calc40 *)
  223.       Calc40 := 31+c;
  224.     end;  (* Calc40 *)
  225.  
  226.     (*─────────────────────────────────────────────────────────────────────*)
  227.  
  228.   begin (* CalcColor *)
  229.     if xElems =  20 then CalcColor := Calc40(c*2);
  230.     if xElems =  40 then CalcColor := Calc40(c);
  231.     if xElems =  80 then CalcColor := Calc40((((c+3) div 2) - 1));
  232.     if xElems = 160 then CalcColor := Calc40((((c+7) div 4) - 1));
  233.   end;  (* CalcColor *)
  234.  
  235.   (*───────────────────────────────────────────────────────────────────────*)
  236.  
  237. begin  (* LoadArray *)
  238.   Info.Sorted := true;
  239.   i := 0;
  240.  
  241.   for c := 1 to Info.xElems do
  242.     for r := 1 to Info.yElems do
  243.       begin
  244.         Inc(i);
  245.         Info.List[i].Key := i;
  246.         Info.List[i].Color := CalcColor(Info.xElems, c);
  247.       end;
  248. end;   (* LoadArray *)
  249.  
  250. (*─────────────────────────────────────────────────────────────────────────*)
  251.  
  252. procedure ShowBlock (var Info : InfoType;
  253.                          Index : IndexType);
  254. var
  255.   x, y, xBlock, yBlock : integer;
  256.  
  257. begin  (* ShowBlock *)
  258.   x := (Index-1) div Info.yElems;
  259.   y := (Index-1) mod Info.yElems;
  260.   xBlock := xMax div Info.xElems;
  261.   yBlock := yMax div Info.yElems;
  262.  
  263.   SetFillStyle(SolidFill, Info.List[Index].Color);
  264.   Bar((x*xBlock), (y*yBlock),
  265.      ((x*xBlock)+(xBlock-2)),((y*yBlock)+(yBlock-2)));
  266. end;   (* ShowBlock *)
  267.  
  268. (*─────────────────────────────────────────────────────────────────────────*)
  269.  
  270. procedure ShowArray (var Info : InfoType);
  271. var
  272.   i : IndexType;
  273.  
  274. begin  (* ShowArray *)
  275.   ClearDevice;
  276.   for i := 1 to Info.Len do
  277.     ShowBlock(Info, i);
  278. end;   (* ShowArray *)
  279.  
  280. (*─────────────────────────────────────────────────────────────────────────*)
  281.