16/PCGPE10/COPPER.PAS

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