home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / misc / pcgame / copper.pas < prev    next >
Pascal/Delphi Source File  |  1994-05-10  |  7KB  |  361 lines
  1. {$X+}
  2. Program Copper;
  3. Uses Crt;
  4.  
  5.  
  6.  
  7. Type
  8.    ColType = Record
  9.                 R,
  10.                 G,
  11.                 B : Byte;
  12.              End;
  13.  
  14.    PalType = Array[0..255] of ColType;
  15.  
  16.    BarType = Record
  17.                 Col : Array[1..20] of ColType;
  18.                 Pos : Array[1..20] of Byte;
  19.                  UP : Array[1..20] of Boolean;
  20.              End;
  21.  
  22.  
  23.  
  24. Var
  25.    Pal1 : PalType;
  26.    Bars : Array[1..40] Of BarType;
  27.    NumBars, NumLines : Byte;
  28.  
  29.  
  30. Procedure Pal(Col, R, G, B : Byte);
  31. Begin
  32.    Asm
  33.       mov   dx, 3c8h
  34.       mov   al, [Col]
  35.       out   dx, al
  36.       inc   dx
  37.       mov   al, [R]
  38.       out   dx, al
  39.       mov   al, [G]
  40.       out   dx, al
  41.       mov   al, [B]
  42.       out   dx, al
  43.    End;
  44. End;
  45.  
  46. Procedure GetPal(Col : Byte; Var R, G, B : Byte);
  47. Var
  48.    Rt,Gt,Bt : Byte;
  49. Begin
  50.    Asm
  51.       mov   dx, 3c7h
  52.       mov   al, [Col]
  53.       out   dx, al
  54.       inc   dx
  55.       inc   dx
  56.       in    al, dx
  57.       mov   [Rt],al
  58.       in    al, dx
  59.       mov   [Gt],al
  60.       in    al, dx
  61.       mov   [Bt],al
  62.    End;
  63.    R := Rt;
  64.    G := Gt;
  65.    B := Bt;
  66. End;
  67.  
  68.  
  69.  
  70. Procedure WaitRetrace; Assembler;
  71. Asm
  72.     mov   dx,3DAh
  73. @@1:
  74.     in    al,dx
  75.     and   al,08h
  76.     jnz   @@1
  77. @@2:
  78.     in    al,dx
  79.     and   al,08h
  80.     jz    @@2
  81. End;
  82.  
  83.  
  84. Procedure SetPal(Var Palet : PalType); Assembler;
  85. Asm
  86.    call  WaitRetrace
  87.    push  ds
  88.    lds   si, Palet
  89.    mov   dx, 3c8h
  90.    mov   al, 0
  91.    out   dx, al
  92.    inc   dx
  93.    mov   cx, 768
  94.    rep   outsb
  95.    pop   ds
  96. End;
  97.  
  98.  
  99. Procedure FadeOut(NoBars, BarSize : Byte);
  100. Var
  101.       F, L : Integer;
  102.    PalFade : PalType;
  103.  
  104. Begin
  105.    For F := 1 to NoBars do
  106.       For L := 1 to BarSize do
  107.       Begin
  108.          If Bars[F].Col[L].R > 0 Then Dec(Bars[F].Col[L].R);
  109.          If Bars[F].Col[L].G > 0 Then Dec(Bars[F].Col[L].G);
  110.          If Bars[F].Col[L].B > 0 Then Dec(Bars[F].Col[L].B);
  111.       End;
  112. End;
  113.  
  114.  
  115.  
  116. Procedure SetMcga;
  117. Begin
  118.    Asm
  119.       mov   ax, 0013h
  120.       int   10h
  121.    End;
  122. End;
  123.  
  124. Procedure SetText;
  125. Begin
  126.    Asm
  127.       mov   ax, 0003h
  128.       int   10h
  129.    End;
  130. End;
  131.  
  132.  
  133.  
  134. Procedure DrawCopper(NoLines,  StartCol, YStart : Byte);
  135. Var
  136.    Loop : Word;
  137. Begin
  138.    For Loop := YStart to YStart + NoLines do
  139.    Begin
  140.       FillChar(Mem[$a000:Loop*320],320,StartCol+Loop-YStart);
  141.    End;
  142. End;
  143.  
  144.  
  145. Procedure SetCopperPal(NoBars, BarSize, YStart, ColStart, Space : Byte);
  146. Var
  147.       Loop : Byte;
  148.      Loop2 : Word;
  149.       IncR : Byte;
  150.        RGB : Byte;
  151.    HalfBar : Byte;
  152.  
  153. Begin
  154.    FillChar(Bars, SizeOf (Bars),0);
  155.    HalfBar := BarSize Div 2;
  156.    IncR := 63 Div HalfBar;
  157.    RGB := 0;
  158.    For Loop := 1 to NoBars do
  159.    Begin
  160.       For Loop2 := 1 to HalfBar do
  161.       Begin
  162.          If RGB = 0 Then
  163.          Bars[Loop].Col[Loop2].R := Loop2 * IncR;
  164.          If RGB = 1 Then
  165.          Bars[Loop].Col[Loop2].G := Loop2 * IncR;
  166.          If RGB = 2 Then
  167.          Bars[Loop].Col[Loop2].B := Loop2 * IncR;
  168.  
  169.          Bars[Loop].Pos[Loop2] := YStart + (Loop-1) * (BarSize+Space) + Loop2 -1 + ColStart;
  170.          Bars[Loop].UP[Loop2] := True
  171.       End;
  172.  
  173.       For Loop2 := HalfBar + 1  to BarSize  do
  174.       Begin
  175.          If RGB = 0 Then
  176.          Bars[Loop].Col[Loop2].R := (BarSize - Loop2) * IncR;
  177.          If RGB = 1 Then
  178.          Bars[Loop].Col[Loop2].G := (BarSize - Loop2) * IncR;
  179.          If RGB = 2 Then
  180.          Bars[Loop].Col[Loop2].B := (BarSize - Loop2) * IncR;
  181.  
  182.          Bars[Loop].Pos[Loop2] := YStart + (Loop-1) * (BarSize+Space) + Loop2 -1 + ColStart;
  183.          Bars[Loop].UP[Loop2] := True
  184.       End;
  185.  
  186.       RGB := (RGB + 1) Mod 3;
  187.    End;
  188.  
  189. End;
  190.  
  191.  
  192.  
  193.  
  194. Procedure RotatePal(NoBars, BarSize, YStart, StartCol, NumLines : Byte;
  195.                     Up : Boolean);
  196.  
  197. Var
  198.    TPal : PalType;
  199.    TCol : ColType;
  200.    Loop,
  201.    Loop2 : Byte;
  202.  
  203. Begin
  204.    FillChar(TPal, 768, 0);
  205.    For Loop := 1 to NoBars do
  206.    Begin
  207.       For Loop2 := 1 to BarSize do
  208.       Begin
  209.          TPal[Bars[Loop].Pos[Loop2]] := Bars[Loop].Col[Loop2];
  210.          If Up Then
  211.          Begin
  212.             If Bars[Loop].Pos[Loop2] = StartCol Then
  213.             Bars[Loop].UP[Loop2] := False;
  214.             If Bars[Loop].Pos[Loop2] = NumLines Then
  215.             Bars[Loop].UP[Loop2] := True;
  216.  
  217.             If Bars[Loop].UP[Loop2] Then
  218.             Dec(Bars[Loop].Pos[Loop2])
  219.             Else
  220.             Inc(Bars[Loop].Pos[Loop2]);
  221.  
  222.          End;
  223.       End;
  224.  
  225.    End;
  226.    SetPal(TPal);
  227.  
  228. End;
  229.  
  230.  
  231. Procedure SetUP(NumLines, NumBars, BarSize, YStart, ColStart, Space : Byte);
  232. Begin
  233.    SetMcga;
  234.    DrawCopper(NumLines,ColStart,YStart);
  235.    SetCopperPal(NumBars, BarSize, YStart, ColStart, Space);
  236. End;
  237.  
  238.  
  239. Procedure DoItAll;
  240. Var
  241.    NumLines,
  242.    NumBars,
  243.    BarSize,
  244.    YStart,
  245.    ColStart,
  246.    Space : Byte;
  247.    Loop : Byte;
  248.  
  249. Begin
  250.    NumLines := 200;
  251.    NumBars := 10;
  252.    BarSize := 10;
  253.    YStart := 0;
  254.    ColStart := 1;
  255.    Space := 5;
  256.    SetUP(NumLines, NumBars, BarSize, YStart, ColStart, Space);
  257.    Repeat
  258.        RotatePal(NumBars, BarSize,YStart, ColStart, NumLines, True);
  259.        If KeyPressed Then
  260.        Begin
  261.           For Loop := 0 to 63 do
  262.           Begin
  263.              RotatePal(NumBars, BarSize,YStart, ColStart, NumLines, True);
  264.              FadeOut(NumBars, BarSize);
  265.           End;
  266.           Exit;
  267.        End;
  268.    Until False;
  269. End;
  270.  
  271.  
  272.  
  273. Procedure Creds;
  274. Var
  275.       R, G, B : Byte;
  276.    R1, G1, B1 : Byte;
  277.          Loop : Byte;
  278.  
  279. Begin
  280.    SetText;
  281.    While KeyPressed do ReadKey;
  282.  
  283.    Asm
  284.       mov   ah, 1
  285.       mov   ch, 1
  286.       mov   cl, 0
  287.       int   10h
  288.    End;
  289.  
  290.    GetPal(7,R,G,B);
  291.    Pal(7,0,0,0);
  292.    WriteLn('Copper Bars Trainer...');
  293.    WriteLn;
  294.    WriteLn('By EzE of Asphyxia.');
  295.    WriteLn;
  296.    WriteLn('Contact Us on ...');
  297.    WriteLn;
  298.    WriteLn;
  299.    WriteLn('the Asphyxia BBS (031) - 7655312');
  300.    WriteLn;
  301.    WriteLn('Email :       eze@');
  302.    WriteLn('         asphyxia@');
  303.    WriteLn('          edwards@');
  304.    WriteLn('           bailey@');
  305.    WriteLn('          mcphail@');
  306.    WriteLn('                  beastie.cs.und.ac.za');
  307.    WriteLn;
  308.    WriteLn('or  peter.edwards@datavert.co.za');
  309.    WriteLn;
  310.    WriteLn('Write me snail-mail at...');
  311.    WriteLn('P.O. Box 2313');
  312.    WriteLn('Hillcrest');
  313.    WriteLn('Natal');
  314.    WriteLn('3650');
  315.    R1 := 0;
  316.    G1 := 0;
  317.    B1 := 0;
  318.    For Loop := 0 to 63 do
  319.    Begin
  320.       WaitRetrace;
  321.       WaitRetrace;
  322.       Pal(7, R1, G1, B1);
  323.       If R1 < R Then Inc(R1);
  324.       If G1 < G Then Inc(G1);
  325.       If B1 < B Then Inc(B1);
  326.    End;
  327.    Asm
  328.       mov   ah, 1
  329.       mov   ch, 1
  330.       mov   cl, 0
  331.       int   10h
  332.    End;
  333.  
  334. End;
  335.  
  336.  
  337. Procedure Fadecurs;
  338. Var
  339.    Loop : Byte;
  340.    R, G, B : Byte;
  341. Begin
  342.    GetPal(7, R, G, B);
  343.    For Loop := 0 to 63 do
  344.    Begin
  345.       WaitRetrace;
  346.       WaitRetrace;
  347.       Pal(7, R, G, B);
  348.       If R > 0 Then Dec(R);
  349.       If G > 0 Then Dec(G);
  350.       If B > 0 Then Dec(B);
  351.    End;
  352. End;
  353.  
  354.  
  355. Begin
  356.    TextAttr := $07;
  357.    While KeyPressed do ReadKey;
  358.    FadeCurs;
  359.    DoItAll;
  360.    Creds;
  361. End.