home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / PASCAL / TESTBLD / TESTBEEL.PAS < prev   
Pascal/Delphi Source File  |  1992-12-02  |  8KB  |  228 lines
  1. program testbld;            (* TESTBEELD  eventuele parameters     *)
  2. uses DOS, CRT;              (* worden in het testbeeld geschreven. *)
  3.                             (* M.G.Carasso Johan de Wittlaan 25    *)
  4.                             (* 5631AP Eindhoven Netherlands        *)
  5. type PalBes = array[0..15,0..2] of byte;        (*   040-816690    *)
  6.  
  7. const Scala: PalBes =
  8. (( 0,  0,  0),              (*   grijsladder,   zwart              *)
  9.  ( 9,  9,  9),              (*        ,,                           *)
  10.  (18, 18, 18),              (*        ,,                           *)
  11.  (27, 27, 27),              (*        ,,                           *)
  12.  (36, 36, 36),              (*        ,,                           *)
  13.  (45, 45, 45),              (*        ,,                           *)
  14.  (54, 54, 54),              (*        ,,                           *)
  15.  (63, 63, 63),              (*        ,,    ,    wit               *)
  16.  ( 0, 63,  0),              (* links/groot/boven,         3-e blok *)
  17.  (32, 32, 63),              (* links/klein/boven                   *)
  18.  ( 0,  0, 63),              (* rechts/klein/boven,        6-e blok *)
  19.  (63,  0,  0),              (* cir/mid onder,links/gr/ond 5-e blok *)
  20.  (63, 63,  0),              (* cirkel/links&rechts onder, 1-e blok *)
  21.  ( 0, 63, 63),              (* rechts/groot/boven,        2-e blok *)
  22.  (63,  0, 63),              (* rechts/groot/onder,        4-e blok *)
  23.  (63, 32,  0));             (* links&rechts/klein/onder            *)
  24.  
  25. var i,j,k: integer;
  26.     r2i,r2: longint;
  27.     pu: registers;
  28.  
  29. procedure WriteD(x,y: word; color: byte);
  30.                             (* snelle scherm procedure rond de BIOS*)
  31.                             (* om. Gebaseerd op PC en PS/2 VIDEO   *)
  32.                             (* SYSTEMEN. Richard Wilton            *)
  33.                             (* Microsoft Press, Kluwer.            *)
  34.                             (* Listingen 4.4 en 5.4                *)
  35. inline($5E/$58/$5B/$8C/$DA/$52/$8A/$CB/$BA/$50/$00/$F7/$E2/$D1/$EB/$D1/
  36.        $EB/$D1/$EB/$03/$D8/$83/$C3/$00/$B8/$00/$A0/$8E/$C0/$80/$E1/$07/
  37.        $80/$F1/$07/$B4/$01/$D2/$E4/$BA/$CE/$03/$B0/$08/$EF/$B8/$05/$02/
  38.        $EF/$B4/$18/$B0/$03/$EF/$26/$8A/$07/$89/$F0/$26/$88/$07/$B8/$08/
  39.        $FF/$EF/$B8/$05/$00/$EF/$B8/$03/$00/$EF/$5A/$8E/$DA);
  40.  
  41. procedure tekst(i,j: integer; st: string);
  42. begin
  43. pu.ah:=$13;
  44. pu.al:=$01;
  45. pu.bl:=$17;
  46. pu.bh:=$00;
  47. pu.cx:=Length(St);
  48. pu.dl:=i;
  49. pu.dh:=j;
  50. pu.es:=Seg(St[1]);
  51. pu.bp:=Ofs(St[1]);
  52. Intr(16,pu)
  53. end;
  54.  
  55. procedure SetMode(mode,page: byte; extra: boolean);
  56. begin
  57. pu.ah:=$0; pu.al:=mode; Intr(16,pu);
  58. pu.ah:=$5; pu.al:=page; Intr(16,pu);
  59. if extra then
  60.    begin
  61.    pu.ah:=$11; pu.al:= $23; pu.bl:=$03; Intr(16,pu)
  62.    end
  63. end;
  64.  
  65. procedure SetBorder(kleur: byte);
  66. begin
  67. pu.ah:=$10; pu.al:=$01; pu.bh:=kleur; Intr(16,pu)
  68. end;
  69.  
  70. procedure palet(reg,r,g,b: byte);
  71. var pu:   registers;
  72.     rega: byte;
  73. begin
  74. case reg of
  75. 00..05: rega:=reg;
  76.     06: rega:=20;
  77.     07: rega:=7;
  78. 08..15: rega:=reg+48;
  79. else
  80.         EXIT
  81.    end;
  82. pu.ax:=$1010;
  83. pu.bl:=rega;
  84. pu.bh:=$00;
  85. pu.cl:=b;
  86. pu.ch:=g;
  87. pu.dl:=b;
  88. pu.dh:=r;
  89. Intr($10,pu);
  90. end;
  91.  
  92. procedure  PaletLees;
  93. var j:   byte;
  94. begin
  95. for j:=0 to 15 do
  96.    Palet(j,scala[j,0],scala[j,1],scala[j,2])
  97. end;
  98.  
  99. procedure invul;
  100. var naam:  string;
  101.     x,y:   word;
  102.     color: byte;
  103. begin
  104. for i:=-306 to 306 do
  105.    begin
  106.    x:=i + 320;
  107.    r2i:=i;
  108.    r2i:=r2i*r2i;
  109.    for j:=-234 to 234 do
  110.       begin
  111.       y:=j + 240;
  112.       r2:=j;
  113.       r2:=r2i+r2*r2;
  114.       if r2>46656 then
  115.          begin
  116.          if ((((j+234) mod 36)=0) OR (((i+306) mod 36)=0)) then
  117.             color:=7
  118.                                                else
  119.             color:=3;
  120.             case i of
  121.             -269 .. -235: begin
  122.                           if ((j>-198) and (j<0   )) then color:=8
  123.                                                      else
  124.                              begin
  125.                              if ((j<198) and (j>=0  )) then color:=11
  126.                              end
  127.                           end;
  128.             -234 .. -199: begin
  129.                           if ((j>-198) and (j<-126)) then color:=9
  130.                                                      else
  131.                              begin
  132.                              if ((j<198) and (j>126)) then color:=15
  133.                              end
  134.                           end;
  135.              199 ..  234: begin
  136.                           if ((j>-198) and (j<-126)) then color:=10
  137.                                                      else
  138.                              begin
  139.                              if ((j<198) and (j>126)) then color:=15
  140.                              end
  141.                           end;
  142.              235 ..  269: begin
  143.                           if ((j>-198) and (j<0   )) then color:=13
  144.                                                      else
  145.                              begin
  146.                              if ((j<198) and (j>=0  )) then color:=14
  147.                              end
  148.                           end;
  149.                end
  150.          end
  151.                else
  152.          begin
  153.          color:=0;
  154.          case j of
  155.          -234 .. -199: color:=7;
  156.          -198 .. -163: if abs(i)>72 then color:=7 else color:=0;
  157.          -162 .. -127: begin
  158.                        if abs(i)>108 then color:=0 else color:=7;
  159.                        if ((i>-91) and (i<-86)) then color:=0
  160.                        end;
  161.          -126 ..  -91: if ((i+225) mod 50)<25 then color:=0 else color:=5;
  162.           -90 ..  -18: case i of
  163.                        -234 .. -145: color:= 12;
  164.                        -144 .. - 75: color:= 13;
  165.                         -74 ..    0: color:=  8;
  166.                           1 ..   74: color:= 14;
  167.                          75 ..  144: color:= 11;
  168.                         145 ..  234: color:= 10;
  169.                            end;
  170.           -13 ..   13: if ((j=0) or (((i+198) mod 36)=0)) then color:=7;
  171.            18 ..   90: case i of
  172.                        -234 .. -180: color:=0;
  173.                        -179 .. -108: if(((i+180) mod 18)>8) then color:=0
  174.                                                             else color:=7;
  175.                        -107 ..  -36: if(((i+108) mod 10)>4) then color:=0
  176.                                                             else color:=7;
  177.                         -35 ..   36: if(((i+ 36) mod  6)>2) then color:=0
  178.                                                             else color:=7;
  179.                          37 ..  108: if(((i -37) mod  4)>1) then color:=0
  180.                                                             else color:=7;
  181.                         109 ..  180: if(((i-109) mod  2)>0) then color:=0
  182.                                                             else color:=7;
  183.                         181 ..  234: color:=0;
  184.                            end;
  185.            91 ..  126: if i<-180 then color:=0
  186.                                  else begin
  187.                                       if i>179 then color:=7
  188.                                                else color:=((i+180) div 45)
  189.                                       end;
  190.  
  191.           127 ..  162: if abs(i)>108 then color:=7 else color:=0;
  192.          else
  193.                begin
  194.                if j>90 then color:=12 else color:=0;
  195.                if abs(i)<18 then color:=11
  196.                end
  197.             end
  198.          end;
  199.       if ((abs(j)<54) and (abs(i)<18)) then
  200.          begin
  201.          color:=0;
  202.          if i=0 then color:=7
  203.          end;
  204.       WriteD(x,y,color)
  205.       end
  206.    end;
  207. tekst(31,7,' SOUNDBASE Tm.    ');
  208. tekst(28,47,'                  ');
  209. TEKST(28,48,'    NEDERLAND 1      ');
  210. naam:='';
  211. if ParamCount>0 then
  212.    begin
  213.    for i:=1 to ParamCount do naam:=concat(naam,' ',ParamStr(i));
  214.    delete(naam,1,1);
  215.    tekst(40-(length(naam) div 2),48,naam)
  216.    end
  217. end;
  218.  
  219. begin
  220. SetMode(18,0,true);
  221. PaletLees;
  222. SetBorder(2);
  223. invul;
  224. repeat until KeyPressed;
  225. SetMode(3,0,false);
  226. end.
  227.  
  228.