home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1991 / 02 / bonus / bolo.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-01-02  |  31.9 KB  |  1,385 lines
  1. (* ------------------------------------------------------ *)
  2. (*                      BOLO.PAS                          *)
  3. (*                      Mega-Bolo                         *)
  4. (*                 Turbo Pascal ab 5.5                    *)
  5. (*          (c) 1990 Peter Messmer & TOOLBOX              *)
  6. (* ------------------------------------------------------ *)
  7. {$A+,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}
  8. {$M 4092,0,655360}
  9.  
  10. PROGRAM MegaBolo;
  11.  
  12. USES
  13.   Crt,Graph,Fonts,Drivers;
  14.  
  15. TYPE
  16.   Image=RECORD
  17.           Size: INTEGER;
  18.           Ima : Pointer;
  19.         END;
  20.   Sou =RECORD
  21.          Frq:INTEGER;
  22.          Del:INTEGER;
  23.        END;
  24.   Spiel=ARRAY[0..97] OF INTEGER;
  25.   Stri=STRING[80];
  26.  
  27. CONST
  28.   MaxLevel=9;
  29.   MaxBall=5;
  30.   MaxTon=64;
  31.   xKorr=16;              (* x-Korrektur des Block-Feldes *)
  32.   yKorr=30;              (* y-  "     "    "     "       *)
  33.   bx=8;                     (* x-Ausdehnung des Balles   *)
  34.   by=6;                     (* y-    "       "     "     *)
  35.   SoundOn:BOOLEAN=TRUE;
  36.   Dicht:FillPatternType=(170,86,170,86,170,86,170,86);
  37.   SoundLen:ARRAY[1..2] OF INTEGER=(48,64);
  38.   Music:ARRAY[1..2,1..MaxTon] OF INTEGER=
  39. ((594,440,594,704,660,704,594,440,594,704,660,704,594,468,
  40. 594,704,660,704,594,468,594,704,660,704,594,468,594,792,704,
  41. 792,594,468,594,792,704,792,594,440,594,792,704,660,562,440,
  42. 562,792,704,660,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
  43. (248,495,594,748,248,594,495,248,187,468,562,660,187,562,
  44. 468,187,220,440,562,660,220,562,440,220,165,418,495,594,165,
  45. 495,418,165,198,396,495,594,198,495,396,198,149,374,440,594,
  46. 149,440,374,149,165,330,396,495,165,396,330,165,187,374,468,
  47. 562,187,468,374,187));
  48.   EGAColors:ARRAY[0..15] OF BYTE=
  49.   (0,114,126,34,29,97,102,113,37,84,111,115,124,26,102,29);
  50.   BlockColor=100;
  51.   LevelNr:ARRAY[1..MaxLevel] OF Spiel=
  52.     ((2,2,0,0,0,0,0,0,0,0,0,0,2,2,                  (* 1 *)
  53.       2,0,0,0,0,2,2,2,0,0,0,0,0,2,
  54.       0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  55.       0,0,2,1,1,1,1,1,1,1,1,2,0,0,
  56.       2,0,0,0,0,0,0,0,0,0,0,0,0,2,
  57.       2,2,2,0,0,0,0,0,0,0,0,2,2,2,
  58.       0,0,0,0,0,0,0,0,0,0,0,0,0,0),
  59.      (1,1,1,1,1,1,1,1,1,0,0,1,1,1,                  (* 2 *)
  60.       1,0,0,2,1,2,0,0,1,0,0,1,1,1,
  61.       1,0,0,2,4,2,0,0,1,1,1,4,1,1,
  62.       2,2,2,2,2,2,2,2,2,2,2,0,1,1,
  63.       0,0,0,0,0,0,0,0,0,0,0,0,1,1,
  64.       0,0,0,0,0,0,0,0,0,0,0,0,1,1,
  65.       0,0,2,2,2,2,2,2,2,2,2,2,2,1),
  66.      (0,2,2,0,0,1,2,2,1,0,0,2,2,0,                  (* 3 *)
  67.       0,0,1,1,1,0,0,0,0,1,1,1,0,0,
  68.       2,2,2,0,0,1,5,6,1,0,0,2,2,2,
  69.       1,0,0,0,0,2,2,2,2,0,0,0,0,1,
  70.       1,0,0,2,2,1,1,1,1,2,2,0,0,1,
  71.       0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  72.       0,0,2,2,0,0,0,0,0,0,2,2,0,0),
  73.      (0,0,0,0,2,6,0,0,6,2,0,0,0,0,                  (* 4 *)
  74.       1,1,1,1,1,2,0,0,2,1,1,1,1,1,
  75.       1,0,0,0,0,0,0,0,0,0,0,0,0,1,
  76.       1,0,2,2,2,2,1,1,2,2,2,2,0,1,
  77.       1,0,0,0,0,0,0,0,0,0,0,0,0,1,
  78.       1,1,1,1,1,0,0,0,0,1,1,1,1,1,
  79.       0,0,2,2,2,2,5,5,2,2,2,2,0,0),
  80.      (2,2,2,0,0,0,2,2,0,0,0,2,2,2,                  (* 5 *)
  81.       2,2,0,0,0,1,1,1,1,0,0,0,2,2,
  82.       2,0,0,0,1,2,2,2,1,1,0,0,0,2,
  83.       0,0,0,4,1,1,1,1,1,1,4,0,0,0,
  84.       0,0,1,1,1,2,7,2,2,1,1,1,0,0,
  85.       0,1,1,1,2,2,2,2,2,2,1,1,1,0,
  86.       8,1,1,1,1,1,1,1,1,1,1,1,1,8),
  87.      (1,2,0,0,0,0,1,0,0,0,0,0,1,1,                  (* 6 *)
  88.       0,2,1,0,0,5,1,0,0,0,0,1,1,0,
  89.       0,0,1,2,1,0,0,3,4,0,1,1,0,0,
  90.       0,0,0,2,1,0,0,4,0,0,0,0,0,0,
  91.       0,0,0,0,1,1,0,0,0,0,1,2,0,0,
  92.       0,0,2,2,2,2,2,2,1,1,1,2,2,2,
  93.       1,1,1,0,0,0,1,1,0,0,0,0,0,0),
  94.      (2,2,2,2,2,2,2,2,2,2,2,2,2,2,                  (* 7 *)
  95.       0,0,0,0,0,1,0,0,0,0,0,0,0,1,
  96.       2,2,2,2,2,2,1,2,2,2,2,2,0,2,
  97.       2,8,0,0,0,0,0,0,0,0,7,2,0,2,
  98.       2,0,0,2,2,2,2,2,2,2,2,2,0,2,
  99.       2,2,0,0,0,0,0,1,0,0,0,0,0,2,
  100.       1,2,2,2,2,2,2,2,2,2,2,2,2,2),
  101.      (2,2,2,0,0,0,1,1,0,0,0,2,2,2,                  (* 8 *)
  102.       2,2,0,0,0,1,1,1,1,0,0,0,2,2,
  103.       2,0,0,0,1,1,1,1,1,1,0,0,0,2,
  104.       0,0,0,2,2,1,1,1,1,2,2,0,0,0,
  105.       2,0,1,1,2,2,1,3,2,2,1,1,0,2,
  106.       0,1,1,1,1,2,2,2,2,1,1,1,1,0,
  107.       1,4,1,1,1,1,2,2,1,1,1,1,4,1),
  108.      (2,2,2,6,2,2,2,1,2,2,2,2,2,2,                  (* 9 *)
  109.       4,0,0,0,0,0,0,2,2,0,0,0,1,2,
  110.       2,2,0,2,2,0,0,2,0,0,2,2,2,2,
  111.       2,1,1,1,2,1,5,2,0,0,0,0,2,1,
  112.       2,2,2,2,2,1,0,2,2,0,2,0,2,1,
  113.       1,8,2,0,0,0,0,8,0,0,2,0,2,0,
  114.       1,1,2,2,1,2,2,2,2,2,2,0,0,0));
  115.  
  116. VAR
  117.   Pic1,Pic2,Pic3,Pic4,Pic5,Pic6,Pic7,
  118.   Pic8,Pic9,Pic10,TextBack,BackPic2,BackPic3:Image;
  119.   ATTHelp:Image;
  120.   ATTHelpShow:BOOLEAN;
  121.   BackPic1:ARRAY[1..MaxBall] OF Image;
  122.   Feld:ARRAY[0..13,0..6] OF INTEGER;
  123.   Blocs:INTEGER;
  124.   Lev:Spiel;
  125.   FMiX,FMaX,FMiY:INTEGER;
  126.   BlockX,BlockY:INTEGER;
  127.   MX,MY:INTEGER;
  128.   ch:CHAR;
  129.   Mono,ATT:BOOLEAN;
  130.   Life:INTEGER;
  131.   Level:INTEGER;
  132.   Vel,g:INTEGER;
  133.   ColNorm,ColBlock:INTEGER;
  134.  
  135. PROCEDURE Init;
  136. VAR
  137.   dr,mo,x,y,Err:INTEGER;
  138.   p:PaletteType;
  139. BEGIN
  140.   Err:=RegisterBGIDriver(@EGAVGADriverProc);
  141.   Err:=RegisterBGIDriver(@HercDriverProc);
  142.   Err:=RegisterBGIDriver(@ATTDriverProc);
  143.   Err:=RegisterBGIDriver(@PC3270DriverProc);
  144.   Err:=RegisterBGIFont(@GothicFontProc);
  145.   Err:=RegisterBGIFont(@SansSerifFontProc);
  146.   Err:=RegisterBGIFont(@TriplexFontProc);
  147.   DetectGraph(dr,mo);
  148.   IF dr<EGA THEN
  149.   BEGIN
  150.     dr:=ATT400;
  151.     mo:=ATT400Hi;
  152.     InitGraph(dr,mo,'');
  153.     IF GraphResult<>0 THEN dr:=CGA;
  154.   END;
  155.   IF dr<EGA THEN
  156.   BEGIN
  157.     CloseGraph;
  158.    Write('Sorry, aber mit dieser Grafikkarte ');
  159.    WriteLn('klappts nicht!');
  160.    WriteLn('Mindestens Hercules oder EGA sollte es sein.');
  161.    WriteLn('Tut mir leid...');
  162.     Halt;
  163.   END
  164.   ELSE
  165.   IF (dr=HercMono) OR (dr=ATT400) THEN
  166.   BEGIN
  167.     Mono:=TRUE;
  168.     IF dr=HercMono THEN
  169.     BEGIN
  170.       mo:=HercMonoHi;
  171.       ATT:=FALSE;
  172.     END
  173.     ELSE
  174.     BEGIN
  175.       mo:=ATT400Hi;
  176.       ATT:=TRUE;
  177.       ATTHelpShow:=FALSE;
  178.     END;
  179.   END
  180.   ELSE
  181.   BEGIN
  182.     Mono:=FALSE;
  183.     ATT:=FALSE;
  184.     mo:=EGAHi;
  185.   END;
  186.   InitGraph(dr,mo,'');
  187.   FOR x:=0 TO 13 DO
  188.     FOR y:=0 TO 6 DO
  189.       Feld[x,y]:=0;
  190.   ClearDevice;
  191.   SetVisualPage(0);
  192.   SetActivePage(0);
  193.   IF NOT(Mono) THEN
  194.   BEGIN
  195.     GetPalette(p);
  196.     FOR x:=0 TO 15 DO
  197.       p.Colors[x]:=EGAColors[x];
  198.     SetAllPalette(p);
  199.     ColNorm:=EGAColors[2];
  200.     ColBlock:=BlockColor;
  201.   END;
  202.   MX:=GetMaxX;
  203.   MY:=GetMaxY;
  204.   FMiX:=(MX-448-32-8) SHR 1;
  205.   FMaX:=FMiX+448+32+8;
  206.   FMiY:=50;
  207.   BlockX:=FMiX+xKorr;       (* x-Beginn des Block-Feldes *)
  208.   BlockY:=FMiY+yKorr;       (* y-  "     "    "      "   *)
  209. END;
  210.  
  211.  
  212. PROCEDURE DelaySec(y:INTEGER);
  213. VAR
  214.   x:WORD;
  215.   ca:CHAR;
  216. BEGIN
  217.   x:=y*100;
  218.   REPEAT
  219.    Delay(10);
  220.    Dec(x);
  221.   UNTIL (KeyPressed) OR (x<0);
  222.   IF KeyPressed THEN ca:=ReadKey;
  223. END;
  224.  
  225. PROCEDURE CatchImage(x1,y1,x2,y2:INTEGER;VAR Ima:Image);
  226. BEGIN
  227.   Ima.Size:=ImageSize(x1,y1,x2,y2);
  228.   GetMem(Ima.Ima,Ima.Size);
  229.   GetImage(x1,y1,x2,y2,Ima.Ima^);
  230. END;
  231.  
  232. PROCEDURE DelSound(Frq,Del:INTEGER);
  233. BEGIN
  234.   IF SoundOn THEN
  235.   BEGIN
  236.     Sound(Frq);
  237.     Delay(Del);
  238.   END;
  239. END;
  240.  
  241. PROCEDURE Color(c:INTEGER);
  242. BEGIN
  243.   IF Mono THEN
  244.    SetColor(1)
  245.   ELSE
  246.    SetColor(c);
  247. END;
  248.  
  249. PROCEDURE FillStyle(f,c:INTEGER);
  250. BEGIN
  251.   IF Mono THEN
  252.    SetFillStyle(f,1)
  253.   ELSE
  254.    SetFillStyle(f,c);
  255. END;
  256.  
  257. PROCEDURE Fill(x,y,c:INTEGER);
  258. BEGIN
  259.   IF Mono THEN
  260.    FloodFill(x,y,1)
  261.   ELSE
  262.    FloodFill(x,y,c);
  263. END;
  264.  
  265. PROCEDURE SetImage(x,y:INTEGER;Ima:Image;Akt:WORD);
  266. BEGIN
  267.   PutImage(x,y,Ima.Ima^,Akt);
  268. END;
  269.  
  270. PROCEDURE SetBack(x,y:INTEGER;Ima:Image;Akt:WORD);
  271. BEGIN
  272.   SetImage(x,y,Ima,Akt);
  273.   FreeMem(Ima.Ima,Ima.Size);
  274. END;
  275.  
  276. PROCEDURE Picture1;                              (* Ball *)
  277. BEGIN
  278.   Color(2);
  279.   Circle(4,4,4);
  280.   Circle(3,3,3);
  281.   FillStyle(1,2);
  282.   Fill(3,3,2);
  283.   CatchImage(0,1,bx,7,Pic1);
  284.   ClearViewPort;
  285. END;
  286.  
  287. PROCEDURE Picture2;                          (* Schläger *)
  288. BEGIN
  289.   Color(6);
  290.   Rectangle(1,1,64,8);
  291.   SetFillStyle(1,0);
  292.   Fill(5,5,6);
  293.   Color(4);
  294.   Rectangle(2,4,61,6);
  295.   FillStyle(1,4);
  296.   Fill(5,5,4);
  297.   Color(6);
  298.   CatchImage(1,1,64,8,Pic2);
  299.   ClearViewPort;
  300. END;
  301.  
  302. PROCEDURE Picture3;                             (* Block *)
  303. BEGIN
  304.   Color(15);
  305.   Rectangle(1,1,32,16);
  306.   Rectangle(3,3,28,12);
  307.   FillStyle(1,15);
  308.   Fill(4,4,15);
  309.   CatchImage(1,1,32,16,Pic3);
  310.   ClearViewPort;
  311. END;
  312.  
  313. PROCEDURE Picture4;                            (* Stein  *)
  314. BEGIN
  315.   Color(14);
  316.   Rectangle(1,1,32,16);
  317.   Rectangle(3,3,28,12);
  318.   IF Mono THEN
  319.    SetFillPattern(Dicht,1)
  320.   ELSE
  321.    SetFillPattern(Dicht,14);
  322.   Fill(4,4,14);
  323.   CatchImage(1,1,32,16,Pic4);
  324.   ClearViewPort;
  325. END;
  326.  
  327. PROCEDURE Picture5;                         (* ExtraBall *)
  328. BEGIN
  329.   Color(13);
  330.   Rectangle(1,1,32,16);
  331.   Rectangle(3,3,28,12);
  332.   CatchImage(1,1,32,16,Pic5);
  333.   ClearViewPort;
  334. END;
  335.  
  336. PROCEDURE Picture6;                        (*  MultiBall *)
  337. BEGIN
  338.   Color(15);
  339.   Rectangle(1,1,32,16);
  340.   Rectangle(3,3,28,13);
  341.   Color(12);
  342.   Circle(16,8,4);
  343.   Circle(15,7,3);
  344.   FillStyle(1,12);
  345.   Fill(14,7,12);
  346.   CatchImage(1,1,32,16,Pic6);
  347.   ClearViewPort;
  348. END;
  349.  
  350. PROCEDURE Picture7;                       (* Gravitation *)
  351. BEGIN
  352.   Color(15);
  353.   Rectangle(1,1,32,16);
  354.   Rectangle(3,3,28,13);
  355.   Color(11);
  356.   SetLineStyle(0,0,1);
  357.   Line(5,7,5,9);
  358.   Line(5,7,15,7);
  359.   Line(5,9,15,9);
  360.   Line(15,7,15,5);
  361.   Line(15,9,15,11);
  362.   Line(15,11,26,8);
  363.   Line(15,5,26,8);
  364.   SetLineStyle(0,0,1);
  365.   FillStyle(1,11);
  366.   Fill(6,8,11);
  367.   CatchImage(1,1,32,16,Pic7);
  368.   ClearViewPort;
  369. END;
  370.  
  371. PROCEDURE Picture8;           (* Ende aller Gemeinheiten *)
  372. BEGIN
  373.   Color(15);
  374.   Rectangle(1,1,32,16);
  375.   Rectangle(3,3,28,13);
  376.   Color(10);
  377.   SetLineStyle(0,0,3);
  378.   Line(3,4,28,12);
  379.   Line(3,12,28,4);
  380.   SetLineStyle(0,0,1);
  381.   CatchImage(1,1,32,16,Pic8);
  382.   ClearViewPort;
  383. END;
  384.  
  385. PROCEDURE Picture9;                            (* Magnet *)
  386. BEGIN
  387.   Color(9);
  388.   Arc(9,8,90,270,6);
  389.   Arc(9,8,90,270,3);
  390.   Line(9,3,18,3);
  391.   Line(9,6,18,6);
  392.   Line(18,3,18,6);
  393.   Line(9,13,18,13);
  394.   Line(9,10,18,10);
  395.   Line(18,13,18,10);
  396.   FillStyle(1,9);
  397.   Fill(9,5,9);
  398.   CatchImage(1,1,32,16,Pic9);
  399.   ClearViewPort;
  400. END;
  401.  
  402. PROCEDURE Picture10;                        (* Austausch *)
  403. BEGIN
  404.   Color(15);
  405.   Rectangle(1,1,32,16);
  406.   Color(8);
  407.   Rectangle(3,3,28,13);
  408.   IF NOT(Mono) THEN
  409.   BEGIN
  410.     SetFillStyle(1,8);
  411.     FloodFill(9,4,8);
  412.   END;
  413.   CatchImage(1,1,32,16,Pic10);
  414.   ClearViewPort;
  415. END;
  416.  
  417.  
  418. PROCEDURE WriteCenter(St:Stri;x,y:INTEGER);
  419. BEGIN
  420.   OutTextXY((MX-TextWidth(St)) SHR 1+x,y,St);
  421. END;
  422.  
  423. PROCEDURE Pictures;
  424. CONST
  425.   St:STRING[30]='Ich initialisiere MEGA-BOLO... ';
  426. BEGIN
  427.   SetTextStyle(1,0,3);
  428.   WriteCenter(St,0,(MY-TextHeight(St)) SHR 1);
  429.   SetActivePage(1);
  430.   SetViewPort(0,0,80,60,TRUE);
  431.   Picture1;
  432.   Picture2;
  433.   Picture3;
  434.   Picture4;
  435.   Picture5;
  436.   Picture6;
  437.   Picture7;
  438.   Picture8;
  439.   Picture9;
  440.   Picture10;
  441. END;
  442.  
  443. PROCEDURE PlayMusic(SoundNr:INTEGER);    (* Titelmelodie *)
  444. VAR
  445.   x:INTEGER;
  446.   ch:CHAR;
  447. BEGIN
  448.   x:=1;
  449.   REPEAT
  450.     DelSound(Music[SoundNr,x],108);
  451.     NoSound;
  452.     Delay(10);
  453.     Inc(x);
  454.     IF x>SoundLen[SoundNr] THEN x:=1;
  455.   UNTIL KeyPressed;
  456.   ch:=ReadKey;
  457. END;
  458.  
  459. PROCEDURE Logo;                         (* Logo ausgeben *)
  460. CONST
  461.   Titel1='toolbox';
  462.   Titel2='MEGA-BOLO';
  463.   Titel3='(C) Copyright 1991 Peter Messmer & toolbox';
  464. VAR
  465.   x:INTEGER;
  466.   ca:CHAR;
  467.  
  468.   PROCEDURE Bas;
  469.   BEGIN
  470.     DelSound(70,80);
  471.     NoSound;
  472.   END;
  473.  
  474.   PROCEDURE BreakSound;
  475.   BEGIN
  476.     IF KeyPressed THEN
  477.     BEGIN
  478.      NoSound;
  479.      SoundOn:=FALSE;
  480.      ca:=ReadKey;
  481.     END;
  482.   END;
  483.  
  484. BEGIN
  485.   FOR x:=0 TO 25 DO                   (* Rahmen aufbauen *)
  486.   BEGIN
  487.     BreakSound;
  488.     IF Mono THEN
  489.       SetColor(1)
  490.      ELSE
  491.       IF x MOD 2=1 THEN SetColor(4) ELSE SetColor(8);
  492.     Rectangle(x*2+1,x*2+1,MX-x*2,MY-x*2);
  493.     DelSound((x+10)*20,0);
  494.   END;
  495.   SetColor(0);
  496.   FOR x:=25 DOWNTO 4 DO
  497.   BEGIN
  498.     BreakSound;
  499.     Rectangle(x*2+1,x*2+1,MX-x*2,MY-x*2);
  500.     DelSound((x+10)*20,0);
  501.   END;
  502.   NoSound;
  503.   Color(6);
  504.   SetTextStyle(1,0,5);
  505.   WriteCenter(Titel1,-1,29);
  506.   Color(4);
  507.   WriteCenter(Titel1,0,30);
  508.   Bas;
  509.   Color(4);
  510.   SetTextStyle(3,0,3);
  511.   WriteCenter('praesentiert',0,80);
  512.   Bas;
  513.   SetTextStyle(4,0,8);
  514.   Color(6);
  515.   WriteCenter(Titel2,3,112);
  516.   Bas;
  517.   WriteCenter(Titel2,2,111);
  518.   Bas;
  519.   Color(4);
  520.   WriteCenter(Titel2,1,110);
  521.   Bas;
  522.   Color(6);
  523.   SetTextStyle(1,0,3);
  524.   WriteCenter(Titel3,1,251);
  525.   Color(4);
  526.   IF NOT(Mono) THEN
  527.     WriteCenter(Titel3,0,250);
  528.   Bas;
  529.   Delay(700);
  530.   REPEAT
  531.     IF KeyPressed THEN ca:=ReadKey;
  532.   UNTIL NOT(KeyPressed);
  533.   PlayMusic(2);
  534.   IF NOT(SoundOn) THEN
  535.   BEGIN
  536.     IF NOT(Mono) THEN
  537.     BEGIN
  538.       ColNorm:=BlockColor;
  539.       ColBlock:=EGAColors[2];
  540.       SetPalette(2,ColNorm);
  541.     END;
  542.   END;
  543. END;
  544.  
  545. PROCEDURE Help;
  546. CONST
  547.   HT:ARRAY[1..13] OF STRING[80]=(
  548. 'Halten Sie den Ball mit Hilfe des Schlaegers im Spielfeld',
  549. 'und raeumen Sie die Steine ab, um in das naechste Bild zu',
  550. 'gelangen. Neun verschiedene Level warten auf Sie.',
  551. 'Vorsicht: Der Ball darf nicht unter den Schlaeger geraten!',
  552. '',
  553. 'Der Schlaeger wird mit den beiden <Shift>-Tasten gesteuert',
  554. 'und mit der <Space>-Taste angehalten. <M> schaltet den',
  555. 'Sound an oder aus. Sollte der Ball in einer Schleife',
  556. 'haengenbleiben, hilft ein kurzer Gravitationsschub mit <G>.',
  557. '','',
  558. 'Viel Spass!','');
  559.  
  560. VAR
  561.   x,y,y4:INTEGER;
  562. BEGIN
  563.   Color(4);
  564.   SetViewPort(0,0,MX,MY,TRUE);
  565.   FOR x:=0 TO 2 DO
  566.     Rectangle(x*2+1,x*2+1,MX-x*2,MY-x*2);
  567.   SetTextStyle(3,0,1);
  568.   y:=70;
  569.   FOR x:=1 TO 13 DO
  570.   BEGIN
  571.     IF NOT(x=4) THEN WriteCenter(HT[x],10,y) ELSE y4:=y;
  572.     y:=y+TextHeight(HT[x]);
  573.   END;
  574.   Color(6);
  575.   WriteCenter(HT[4],10,y4);
  576.   SetTextStyle(1,0,4);
  577.   WriteCenter('MEGA-BOLO',0,20);
  578.   SetTextStyle(1,0,2);
  579.   OutTextXY(MX-20-TextWidth('P.M.'),
  580.             MY-6-TextHeight('P.M.'),'P.M.');
  581.   Color(1);
  582. END;
  583.  
  584. PROCEDURE GlobHelp;
  585. BEGIN
  586.   IF NOT(ATT) THEN Help;
  587.   SetActivePage(0);
  588.   SetViewPort(0,0,MX,MY,FALSE);
  589.   ClearViewPort;
  590. END;
  591.  
  592. PROCEDURE SetBlocs;
  593. VAR
  594.   x,y:INTEGER;
  595.   u,v:INTEGER;
  596. BEGIN
  597.   CatchImage(BlockX,BlockY,
  598.              BlockX+31,BlockY+15,BackPic3);
  599.   FOR y:=0 TO 6 DO
  600.     FOR x:=0 TO 13 DO
  601.     BEGIN
  602.       u:=(x SHL 5)+BlockX;
  603.       v:=(y SHL 4)+BlockY;
  604.       CASE Feld[x,y] OF
  605.         1: SetImage(u,v,Pic3,0);
  606.         2: SetImage(u,v,Pic4,0);
  607.         3: SetImage(u,v,Pic5,0);
  608.         4: SetImage(u,v,Pic6,0);
  609.         5: SetImage(u,v,Pic7,0);
  610.         6: SetImage(u,v,Pic8,0);
  611.         7: SetImage(u,v,Pic9,2);
  612.         8: SetImage(u,v,Pic10,0);
  613.       END;
  614.     END;
  615. END;
  616.  
  617. PROCEDURE WriteLife;
  618. VAR
  619.   St:STRING[2];
  620. BEGIN
  621.   Color(1);
  622.   SetTextStyle(1,0,3);
  623.   Str(Life,St);
  624.   OutTextXY((MX-FMaX-TextWidth('Baelle')) SHR 1+FMaX,
  625.             100,'Baelle');
  626.   SetTextStyle(1,0,4);
  627.   OutTextXY((MX-FMaX-TextWidth(St)) SHR 1+FMaX,
  628.             140,St);
  629. END;
  630.  
  631. PROCEDURE WriteLevel;
  632. VAR
  633.   St:STRING[5];
  634.   w:WORD;
  635. BEGIN
  636.   Color(1);
  637.   SetTextStyle(1,0,3);
  638.   OutTextXY(((FMiX-8-TextWidth('Level')) SHR 1)+8,
  639.              100,'Level');
  640.   IF Level=MaxLevel THEN
  641.   BEGIN
  642.     SetTextStyle(1,0,3);
  643.     St:='ENDE';
  644.   END
  645.   ELSE
  646.   BEGIN
  647.     SetTextStyle(1,0,4);
  648.     Str(Level,St);
  649.   END;
  650.   OutTextXY(((FMiX-8-TextWidth(St)) SHR 1)+8,140,St);
  651. END;
  652.  
  653. PROCEDURE PaintFeld;
  654. VAR
  655.   x:INTEGER;
  656. BEGIN
  657.   SetViewPort(10,FMiY,MX-10,330,TRUE);
  658.   ClearViewPort;
  659.   SetViewPort(0,0,MX,MY,TRUE);
  660.   Color(4);
  661.   Rectangle(FMiX,FMiY,FMaX,330);
  662.   Rectangle(FMiX-5,FMiY,FMaX+5,330);
  663.   Color(6);
  664.   Rectangle(FMiX-3,49,FMaX+3,331);
  665.   Color(7);
  666.   FillStyle(11,7);
  667.   Fill(FMiX+1,51,4);
  668.   SetBlocs;
  669.   WriteLife;
  670.   WriteLevel;
  671. END;
  672.  
  673. PROCEDURE Title;
  674. CONST Titel1='MEGA-BOLO';
  675. VAR
  676.   x:INTEGER;
  677. BEGIN
  678.   Color(4);
  679.   FOR x:=0 TO 2 DO
  680.     Rectangle(x*2+1,x*2+1,MX-x*2,MY-x*2);
  681.   SetTextStyle(4,0,5);
  682.   Color(6);
  683.   WriteCenter(Titel1,1,1);
  684.   Color(4);
  685.   WriteCenter(Titel1,0,1);
  686. END;
  687.  
  688. PROCEDURE CenterText(t:Stri;VAR x,y:INTEGER);
  689. BEGIN
  690.   x:=(MX-TextWidth(t)) SHR 1;
  691.   y:=((MY-TextHeight(t)) SHR 1)+FMiY;
  692.   CatchImage(x,y,x+TextWidth(t),
  693.              y+TextHeight(t)+30,TextBack);
  694.   OutTextXY(x,y,t);
  695. END;
  696.  
  697. PROCEDURE ZoomText(t:Stri;s,c,Font,cl:INTEGER;VAR ca:CHAR);
  698. VAR
  699.   x,y,Count,Col:INTEGER;
  700. BEGIN
  701.   IF KeyPressed THEN ca:=ReadKey;
  702.   REPEAT
  703.     Col:=GetColor;
  704.     FOR Count:=s TO c DO
  705.     BEGIN
  706.       SetTextStyle(Font,0,Count);
  707.       Color(cl);
  708.       CenterText(t,x,y);
  709.       Delay(200);
  710.       IF Count=c THEN Delay(400);
  711.       IF s=c THEN REPEAT UNTIL KeyPressed;
  712.       SetBack(x,y,TextBack,0);
  713.     END;
  714.     SetColor(Col);
  715.   UNTIL KeyPressed;
  716.   ca:=ReadKey;
  717. END;
  718.  
  719. PROCEDURE Ausstieg;
  720. VAR
  721.   x,y:INTEGER;
  722.   ca:CHAR;
  723.   St:STRING[3];
  724. BEGIN
  725.   SetTextStyle(1,0,5);
  726.   CenterText('Abbruch ? (J/N):     ',x,y);
  727.   ca:=UpCase(ReadKey);
  728.   IF (ca='Y') OR (ca='J') THEN
  729.     St:='Ja'
  730.   ELSE
  731.     St:='Nein';
  732.   OutTextXY(x+TextWidth('Abbruch ?  (J/N):'),y,St);
  733.   Delay(500);
  734.   IF (ca='Y') OR (ca='J') THEN
  735.   BEGIN
  736.     CloseGraph;
  737.     RestoreCrtMode;
  738.     Halt;
  739.   END;
  740.   SetBack(x,y,TextBack,0);
  741. END;
  742.  
  743. FUNCTION Restart:BOOLEAN;
  744. VAR
  745.   St:STRING;
  746.   x,y:INTEGER;
  747. BEGIN
  748.   SetTextStyle(1,0,5);
  749.   CenterText('Nochmal ? (J/N):    ',x,y);
  750.   ch:=UpCase(ReadKey);
  751.   IF ch='N' THEN
  752.   BEGIN
  753.     Restart:=FALSE;
  754.     St:='Nein';
  755.   END
  756.   ELSE
  757.   BEGIN
  758.     Restart:=TRUE;
  759.     St:='Ja';
  760.   END;
  761.   OutTextXY(x+TextWidth('Restart ?  (Y/N):'),y,St);
  762.   Delay(500);
  763.   SetBack(x,y,TextBack,0);
  764. END;
  765.  
  766. PROCEDURE AllLevels;
  767. VAR
  768.   x,y:INTEGER;
  769. BEGIN
  770.   Delay(200);
  771.   Color(6);
  772.   SetTextStyle(1,0,5);
  773.   CenterText('Glueckwunsch !',x,y);
  774.   PlayMusic(1);
  775.   SetBack(x,y,TextBack,0);
  776. END;
  777.  
  778. PROCEDURE Go;
  779. CONST
  780.   vi:INTEGER=4;
  781. VAR
  782.   xb,yb,yMax,Count,bc,BallCatch:INTEGER;
  783.   x,y:ARRAY[1..MaxBall] OF INTEGER;
  784.   vv,vh:ARRAY[1..MaxBall] OF REAL;
  785.   t,vb:REAL;
  786.   ca:CHAR;
  787.   St:STRING[3];
  788.   Multi:BOOLEAN;
  789.   BallAnz:INTEGER;
  790.  
  791.   PROCEDURE GetKey;
  792.   VAR
  793.     Count:INTEGER;
  794.   BEGIN
  795.     ca:=UpCase(ReadKey);
  796.     IF ca=#0 THEN ca:=UpCase(ReadKey);
  797.     CASE ca OF
  798.       ' ': vb:=0;
  799.       'G': BEGIN
  800.              IF BallAnz>1 THEN
  801.              FOR Count:=1 TO BallAnz DO
  802.                vv[Count]:=vv[Count]+(-6)*t
  803.              ELSE
  804.                vv[1]:=vv[1]+(-6)*t;
  805.            END;
  806.       'M',
  807.       'S',
  808.       'Q': IF SoundOn THEN
  809.            BEGIN
  810.              SoundOn:=FALSE;
  811.              IF NOT(Mono) THEN
  812.              BEGIN
  813.                ColNorm:=BlockColor;
  814.                ColBlock:=EGAColors[2];
  815.                SetPalette(2,ColNorm);
  816.              END;
  817.            END
  818.            ELSE
  819.            BEGIN
  820.              SoundOn:=TRUE;
  821.              IF NOT(Mono) THEN
  822.              BEGIN
  823.                ColBlock:=BlockColor;
  824.                ColNorm:=EGAColors[2];
  825.                SetPalette(2,ColNorm);
  826.              END;
  827.            END;
  828.       #27: Ausstieg;
  829.     ELSE
  830.       BEGIN
  831.         IF NOT(ATT) THEN      (* nicht ATT, andere Seite *)
  832.         BEGIN
  833.           SetVisualPage(1);
  834.           DelaySec(60);
  835.           SetVisualPage(0);
  836.         END
  837.         ELSE
  838.         BEGIN
  839.           CatchImage(0,0,MX,MY,TextBack);
  840.           IF NOT(ATTHelpShow) THEN
  841.           BEGIN                         (* Help aufbauen *)
  842.             ClearDevice;
  843.             Help;
  844.             DelaySec(60);
  845.             CatchImage(0,0,MX,MY,ATTHelp);
  846.             SetBack(0,0,TextBack,0);
  847.             ATTHelpShow:=TRUE;
  848.           END
  849.           ELSE
  850.           BEGIN                         (* Help anzeigen *)
  851.             SetImage(0,0,ATTHelp,0);
  852.             DelaySec(60);
  853.           END;
  854.           SetBack(0,0,TextBack,0);
  855.         END;
  856.       END;
  857.     END;
  858.   END;
  859.  
  860.   PROCEDURE GetShiftKey;
  861.   VAR
  862.     Status:BYTE;
  863.   BEGIN
  864.     Status:=Mem[$040:$017] AND 3;     (* Tastatur-Status *)
  865.     IF Status<>0 THEN
  866.         CASE Status OF
  867.          1 : IF vb > 0 THEN
  868.                vb:=vb+vi                (* Shift rechts ? *)
  869.              ELSE
  870.                vb:=vi;
  871.          2 : IF vb < 0 THEN
  872.                vb:=vb-vi                (* Shift links  ? *)
  873.              ELSE
  874.                vb:=-vi;
  875.         ELSE
  876.          vb:=0;                              (* beide ?  *)
  877.       END;
  878.   END;
  879.  
  880.   PROCEDURE PlopOnBar(VAR yNew:INTEGER);
  881.   BEGIN
  882.     vv[bc]:=(-1)*vv[bc]-0.1*vv[bc];
  883.     vh[bc]:=vh[bc]+vb;
  884.     yNew:=yb-8;
  885.     DelSound(1200,1);
  886.   END;
  887.  
  888.   PROCEDURE AskPlopOnBloc(VAR xNew,yNew:INTEGER);
  889.   VAR
  890.     xp,yp:INTEGER;
  891.  
  892.     PROCEDURE Bloc;
  893.     BEGIN
  894.       SetImage((xp SHL 5)+BlockX,(yp SHL 4)+BlockY,
  895.                BackPic3,0);
  896.       Feld[xp,yp]:=0;
  897.       Dec(Blocs);
  898.       DelSound(1000,10);
  899.       NoSound;
  900.     END;
  901.  
  902.     PROCEDURE Hard;
  903.     BEGIN
  904.       DelSound(1300,10);
  905.       NoSound;
  906.     END;
  907.  
  908.     PROCEDURE Extraball;
  909.     VAR
  910.       Count:INTEGER;
  911.     BEGIN
  912.       SetImage((xp SHL 5)+BlockX,(yp SHL 4)+BlockY,
  913.                 BackPic3,0);
  914.       SetColor(0);
  915.       Str(Life,St);
  916.       SetTextStyle(1,0,4);
  917.       OutTextXY(((MX-FMaX-TextWidth(St)) SHR 1)+FMaX,
  918.                 140,St);
  919.       Inc(Life);
  920.       Color(1);
  921.       WriteLife;
  922.       Feld[xp,yp]:=0;
  923.       FOR Count:=1 TO 30 DO
  924.         DelSound(Count*100,10);
  925.     END;
  926.  
  927.     PROCEDURE MultiBall;
  928.     VAR
  929.       Count,Count2:INTEGER;
  930.       nb:INTEGER;
  931.     BEGIN
  932.       SetImage((xp SHL 5)+BlockX,(yp SHL 4)+BlockY,
  933.                BackPic3,0);
  934.       Feld[xp,yp]:=0;
  935.       SetColor(0);
  936.       Str(Life,St);
  937.       SetTextStyle(1,0,4);
  938.       OutTextXY(((MX-FMaX-TextWidth(St)) SHR 1)+FMaX,
  939.                 140,St);
  940.       Inc(Life);
  941.       Color(1);
  942.       WriteLife;
  943.       nb:=BallAnz+1;
  944.       x[nb]:=(xp SHL 5)+BlockX+xKorr;
  945.       y[nb]:=(yp SHL 4)+BlockY+8;
  946.       vv[nb]:=Round((-1)*(vv[bc]/2))+1;
  947.       vh[nb]:=Round((-1)*(vh[bc]/2))+1;
  948.       CatchImage(x[nb],y[nb],
  949.                  x[nb]+bx,y[nb]+by,
  950.                  BackPic1[nb]);
  951.       SetImage(x[nb],y[nb],Pic1,0);
  952.       FOR Count:=60 TO 62 DO
  953.       BEGIN
  954.         Delay(10);
  955.         FOR Count2:=500 TO Count*10 DO
  956.           DelSound(Count2,1);
  957.         NoSound;
  958.       END;
  959.       Multi:=TRUE;
  960.     END;
  961.  
  962.     PROCEDURE Gravitation;
  963.     VAR
  964.       Count:INTEGER;
  965.     BEGIN
  966.       SetImage((xp SHL 5)+BlockX,(yp SHL 4)+BlockY,
  967.                BackPic3,0);
  968.       Feld[xp,yp]:=0;
  969.       g:=-3;
  970.       FOR Count:=100 DOWNTO 50 DO
  971.       BEGIN
  972.         DelSound(Count*10,5);
  973.         NoSound;
  974.       END;
  975.       FOR Count:=50 TO 100 DO
  976.       BEGIN
  977.         DelSound(Count*10,5);
  978.         NoSound;
  979.       END;
  980.     END;
  981.  
  982.     PROCEDURE EndeGravit;
  983.     VAR
  984.       Count:INTEGER;
  985.     BEGIN
  986.       SetImage((xp SHL 5)+BlockX,(yp SHL 4)+BlockY,
  987.                BackPic3,0);
  988.       Feld[xp,yp]:=0;
  989.       g:=0;
  990.       vi:=4;
  991.       FOR Count:=50 TO 100 DO
  992.       BEGIN
  993.         DelSound(Count*10,5);
  994.         NoSound;
  995.       END;
  996.       FOR Count:=100 DOWNTO 50 DO
  997.       BEGIN
  998.         DelSound(Count*10,5);
  999.         NoSound;
  1000.       END;
  1001.     END;
  1002.  
  1003.     PROCEDURE Magnet;
  1004.     VAR
  1005.       Count:INTEGER;
  1006.     BEGIN
  1007.       xNew:=(xp SHL 5)+BlockX+20;
  1008.       yNew:=(yp SHL 4)+BlockY+4;
  1009.       SetImage(xNew,yNew,Pic1,0);
  1010.       FOR Count:=100 DOWNTO 50 DO
  1011.       BEGIN
  1012.         DelSound(Count*10,50);
  1013.         NoSound;
  1014.       END;
  1015.       Inc(BallCatch);
  1016.       IF BallAnz-BallCatch=0 THEN
  1017.       BEGIN
  1018.         Life:=0;
  1019.         yMax:=400;
  1020.       END
  1021.       ELSE
  1022.       BEGIN
  1023.         vv[bc]:=0;
  1024.         vh[bc]:=0;
  1025.         ZoomText('Ball futsch!',5,5,1,GetColor,ch);
  1026.       END;
  1027.     END;
  1028.  
  1029.     PROCEDURE Umtasten;
  1030.     VAR
  1031.       Count:INTEGER;
  1032.     BEGIN
  1033.       SetImage((xp SHL 5)+BlockX,(yp SHL 4)+BlockY,
  1034.                BackPic3,0);
  1035.       Feld[xp,yp]:=0;
  1036.       vi:=-4;
  1037.       FOR Count:=1 TO 10 DO
  1038.       BEGIN
  1039.         DelSound(Count*100,10);
  1040.         NoSound;
  1041.         Delay(5);
  1042.       END;
  1043.     END;
  1044.  
  1045.     PROCEDURE PlopBlocAway;
  1046.     VAR
  1047.       yz,xz:INTEGER;
  1048.       m:REAL;
  1049.     BEGIN
  1050.       IF xNew=x[bc] THEN       (* keine Vertikalbewegung *)
  1051.         vv[bc]:=-vv[bc]
  1052.       ELSE
  1053.         IF yNew=y[bc] THEN   (* keine Horizontalbewegung *)
  1054.           vh[bc]:=-vh[bc]
  1055.         ELSE
  1056.           IF Abs(vh[bc])=Abs(vv[bc]) THEN
  1057.                                      (* Diagonalbewegung *)
  1058.           BEGIN
  1059.             vh[bc]:=-vh[bc];
  1060.             vv[bc]:=-vv[bc];
  1061.           END
  1062.           ELSE
  1063.           BEGIN          (* Ein bisschen Vektorgeometrie *)
  1064.             m:=(yNew-y[bc])/(xNew-x[bc]);
  1065.             IF vh[bc]<0 THEN
  1066.                                 (* Horizontal nach links *)
  1067.             BEGIN
  1068.               yz:=Round(m*(((xp+1) SHL 5)+
  1069.                         BlockX-xNew)+yNew);
  1070.               IF vv[bc]<0 THEN           (* nach Unten ? *)
  1071.               BEGIN           (* Decke oder rechte Seite *)
  1072.                 IF yz-((yp SHL 4)+BlockY+4)<0 THEN
  1073.                 BEGIN
  1074.                   xz:=Round((1/m)*((yp SHL 4)+
  1075.                           BlockY-by-yNew)+xNew);
  1076.                   xNew:=xz;
  1077.                   yNew:=(yp SHL 4)+BlockY-by;
  1078.                   vv[bc]:=-vv[bc];    (* Decken-Aufprall *)
  1079.                 END
  1080.                 ELSE
  1081.                 BEGIN
  1082.                   vh[bc]:=-vh[bc];    (* Seiten-Aufprall *)
  1083.                   xNew:=((xp+1) SHL 5)+BlockX;
  1084.                   yNew:=yz;
  1085.                 END;
  1086.               END
  1087.               ELSE
  1088.               BEGIN           (* Boden oder rechte Seite *)
  1089.                 IF yz-(((yp+1) SHL 4)+BlockY)>0 THEN
  1090.                 BEGIN
  1091.                   vv[bc]:=-vv[bc];     (* Boden-Aufprall *)
  1092.                   xz:=Round((1/m)*(((yp+1) SHL 4)
  1093.                             +BlockY-yNew)+xNew);
  1094.                   xNew:=xz;
  1095.                   yNew:=((yp+1) SHL 4)+BlockY;
  1096.                 END
  1097.                 ELSE
  1098.                 BEGIN
  1099.                   vh[bc]:=-vh[bc];    (* Seiten-Aufprall *)
  1100.                   xNew:=((xp+1) SHL 5)+BlockX;
  1101.                   yNew:=yz;
  1102.                 END;
  1103.               END;
  1104.             END
  1105.             ELSE               (* Horizontal nach rechts *)
  1106.             BEGIN
  1107.               yz:=Round(m*((xp SHL 5)
  1108.                            +BlockX-by-xNew)+yNew);
  1109.               IF vv[bc]<0 THEN
  1110.               BEGIN            (* Decke oder linke Seite *)
  1111.                 IF yz-((yp SHL 4)+4+BlockY)<0 THEN
  1112.                 BEGIN
  1113.                   vv[bc]:=-vv[bc];    (* Decken-Aufprall *)
  1114.                   xz:=Round((1/m)*((yp SHL 4)
  1115.                             +BlockY-by-yNew)+xNew);
  1116.                   xNew:=xz;
  1117.                   yNew:=(yp SHL 4)+BlockY-by;
  1118.                 END
  1119.                 ELSE
  1120.                 BEGIN
  1121.                   vh[bc]:=-vh[bc];    (* Seiten-Aufprall *)
  1122.                   xNew:=(xp SHL 5)+BlockX-bx;
  1123.                   yNew:=yz;
  1124.                 END;
  1125.               END
  1126.               ELSE
  1127.               BEGIN            (* Boden oder linke Seite *)
  1128.                 IF yz-(((yp+1) SHL 4)+BlockY)>0 THEN
  1129.                 BEGIN
  1130.                   vv[bc]:=-vv[bc];     (* Boden-Aufprall *)
  1131.                   xz:=Round((1/m)*(((yp+1) SHL 4)
  1132.                             +BlockY-yNew)+xNew);
  1133.                   xNew:=xz;
  1134.                   yNew:=((yp+1) SHL 4)+BlockY;
  1135.                 END
  1136.                 ELSE
  1137.                 BEGIN
  1138.                   vh[bc]:=-vh[bc];    (* Seiten-Aufprall *)
  1139.                   xNew:=(xp SHL 5)+BlockX-bx;
  1140.                   yNew:=yz;
  1141.                 END;
  1142.               END;
  1143.             END;
  1144.           END;
  1145.        CASE  Feld[xp,yp] OF
  1146.          1:   Bloc;
  1147.          2:   Hard;
  1148.          3:   Extraball;
  1149.          4:   MultiBall;
  1150.          5:   Gravitation;
  1151.          6:   EndeGravit;
  1152.          7:   Magnet;
  1153.          8:   Umtasten;
  1154.        END;
  1155.      END;
  1156.  
  1157.    BEGIN                          (* AskPlopOnBloc-Rumpf *)
  1158.      yp:=(yNew-BlockY) DIV 16;
  1159.      xp:=(xNew-BlockX) DIV 32;
  1160.      IF Feld[xp,yp]<>0 THEN
  1161.        PlopBlocAway
  1162.      ELSE
  1163.      BEGIN
  1164.        IF ((yNew+by-BlockY) DIV 16 > yp)  AND
  1165.           ((yNew+by-BlockY) DIV 16<7) THEN
  1166.        BEGIN
  1167.          yp:=(yNew+bx-BlockY) DIV 16;
  1168.          IF Feld[xp,yp]<>0 THEN
  1169.            PlopBlocAway;
  1170.        END
  1171.        ELSE
  1172.        BEGIN
  1173.          IF ((xNew+bx-BlockX) DIV 32>xp) AND
  1174.             ((xNew+bx-BlockX) DIV 32<14) THEN
  1175.          BEGIN
  1176.            xp:=(xNew+bx-BlockX) DIV 32;
  1177.            IF Feld[xp,yp]<>0 THEN
  1178.              PlopBlocAway;
  1179.          END;
  1180.        END;
  1181.      END;
  1182.    END;
  1183.  
  1184.    PROCEDURE RandSound;
  1185.    BEGIN
  1186.      DelSound(500,10);
  1187.      NoSound;
  1188.    END;
  1189.  
  1190.    PROCEDURE SetBar;
  1191.    BEGIN
  1192.      PutImage(xb,yb,BackPic2.Ima^,0);
  1193.      FreeMem(BackPic2.Ima,BackPic2.Size);
  1194.      xb:=xb+Round(vb*t);
  1195.      IF xb<FMiX THEN
  1196.      BEGIN
  1197.        vb:=(-1)*vb;
  1198.        xb:=FMiX;
  1199.      END;
  1200.      IF xb+64>FMaX THEN
  1201.      BEGIN
  1202.        vb:=(-1)*vb;
  1203.        xb:=FMaX-64;
  1204.      END;
  1205.      CatchImage(xb,yb,xb+63,yb+7,BackPic2);
  1206.      PutImage(xb,yb,Pic2.Ima^,0);
  1207.    END;
  1208.  
  1209.    PROCEDURE MoveBall(z:INTEGER);
  1210.    VAR
  1211.      xNew,yNew:INTEGER;
  1212.    BEGIN
  1213.      PutImage(x[z],y[z],BackPic1[z].Ima^,0);
  1214.      FreeMem(BackPic1[z].Ima,BackPic1[z].Size);
  1215.      IF z>1 THEN MoveBall(z-1)
  1216.      ELSE
  1217.       IF vb<>0 THEN
  1218.        SetBar;
  1219.      bc:=z;           (* globale Variable für Ballnummer *)
  1220.                          (* ist schneller als Parameter !*)
  1221.      IF NOT((vv[z]=0) AND (vh[z]=0)) THEN
  1222.      BEGIN
  1223.        vv[z]:=vv[z]+g*t;
  1224.        yNew:=y[z]+Round(((g/2)*t*t)-(vv[z]*t));
  1225.        xNew:=x[z]+Round(vh[bc]*t);
  1226.        IF xNew+bx>FMaX THEN
  1227.        BEGIN
  1228.          vh[z]:=(-1)*vh[z];
  1229.          RandSound;
  1230.          xNew:=FMaX-bx;
  1231.        END;
  1232.        IF xNew<FMiX THEN
  1233.        BEGIN
  1234.          vh[z]:=(-1)*vh[z];
  1235.          RandSound;
  1236.          xNew:=FMiX;
  1237.        END;
  1238.        IF yNew<FMiY THEN
  1239.        BEGIN
  1240.          vv[z]:=(-1)*vv[z];
  1241.          RandSound;
  1242.          yNew:=FMiY;
  1243.        END;
  1244.        IF (yNew+bx>yb) AND (yNew<yb) AND
  1245.           (xNew+bx>xb) AND (xNew<xb+64) THEN
  1246.          PlopOnBar(yNew);
  1247.        IF (yNew<192) AND (yNew>72) AND
  1248.           (xNew>FMiX+bx) AND (xNew<FMiX+448+xKorr) THEN
  1249.          AskPlopOnBloc(xNew,yNew);
  1250.        IF yNew>yMax THEN yMax:=yNew;
  1251.      END;
  1252.      CatchImage(xNew,yNew,xNew+bx,yNew+by,BackPic1[z]);
  1253.      PutImage(xNew,yNew,Pic1.Ima^,0);
  1254.      x[z]:=xNew;
  1255.      y[z]:=yNew;
  1256.    END;
  1257.  
  1258.   PROCEDURE InitKonst;
  1259.   BEGIN
  1260.     Multi:=FALSE;
  1261.     BallCatch:=0;
  1262.     BallAnz:=1;
  1263.     x[1]:=BlockX+by*32+13;
  1264.     y[1]:=200;
  1265.     vv[1]:=-15;
  1266.     vh[1]:=0;
  1267.     xb:=BlockX+by*32-16;
  1268.     yb:=300;
  1269.     vb:=0;
  1270.     t:=0.1;
  1271.   END;
  1272.  
  1273.   PROCEDURE LifeLost;
  1274.   VAR
  1275.     Count:INTEGER;
  1276.   BEGIN
  1277.     Dec(Life);
  1278.     FOR Count:=10 DOWNTO 1 DO
  1279.     BEGIN
  1280.       DelSound(Count*100,50);
  1281.       NoSound;
  1282.     END;
  1283.     IF Life>=0 THEN
  1284.       ZoomText('Ball futsch!',5,5,1,GetColor,ch);
  1285.     FOR Count:=1 TO BallAnz DO
  1286.       SetBack(x[Count],y[Count],BackPic1[Count],0);
  1287.   END;
  1288.  
  1289.   PROCEDURE AllBlocs;
  1290.   VAR
  1291.     Count:INTEGER;
  1292.   BEGIN
  1293.     FOR Count:=1 TO 10 DO
  1294.       DelSound(Count*100,50);
  1295.     NoSound;
  1296.     IF Level=MaxLevel THEN
  1297.       AllLevels
  1298.     ELSE
  1299.       ZoomText('You did it...',1,6,1,GetColor,ch);
  1300.   END;
  1301.  
  1302.   PROCEDURE GetFirstPictures;
  1303.   BEGIN
  1304.     CatchImage(x[1],y[1],x[1]+bx,y[1]+by,BackPic1[1]);
  1305.     SetImage(x[1],y[1],Pic1,0);
  1306.     CatchImage(xb,yb,xb+63,yb+7,BackPic2);
  1307.     SetImage(xb,yb,Pic2,0);
  1308.   END;
  1309.  
  1310. BEGIN                                        (* Go-Rumpf *)
  1311.   REPEAT
  1312.     InitKonst;
  1313.     IF KeyPressed THEN ca:=ReadKey;
  1314.     PaintFeld;
  1315.     GetFirstPictures;
  1316.     REPEAT
  1317.       Delay(Vel);
  1318.       NoSound;
  1319.       IF KeyPressed THEN GetKey;
  1320.       GetShiftKey;
  1321.       yMax:=0;
  1322.       MoveBall(BallAnz);
  1323.       IF Multi THEN
  1324.       BEGIN
  1325.         Multi:=FALSE;
  1326.         Inc(BallAnz);
  1327.       END;
  1328.     UNTIL (yMax>320) OR (Blocs=0);
  1329.     IF yMax>320 THEN LifeLost;
  1330.   UNTIL (Blocs=0) OR (Life<0);
  1331.   IF Blocs=0 THEN
  1332.     AllBlocs
  1333.   ELSE
  1334.   BEGIN
  1335.     NoSound;
  1336.     ZoomText('Game Over',1,6,1,GetColor,ch);
  1337.   END;
  1338.   NoSound;
  1339. END;
  1340.  
  1341. PROCEDURE InitFeld;
  1342. VAR
  1343.   x,y:INTEGER;
  1344. BEGIN
  1345.   Blocs:=0;
  1346.   FOR y:=0 TO 6 DO
  1347.     FOR x:=0 TO 13 DO
  1348.     BEGIN
  1349.       Feld[x,y]:=Lev[y*14+x];
  1350.       IF Feld[x,y]=1 THEN Inc(Blocs);
  1351.     END;
  1352. END;
  1353.  
  1354.  
  1355. PROCEDURE Start;
  1356. BEGIN
  1357.   SetViewPort(0,0,MX,MY,TRUE);
  1358.   ClearViewPort;
  1359.   Title;
  1360.   REPEAT
  1361.     Life:=3;
  1362.     Level:=1;
  1363.     Vel:=12;
  1364.     g:=0;
  1365.     REPEAT
  1366.       Lev:=LevelNr[Level];
  1367.       InitFeld;
  1368.       Go;
  1369.       Inc(Level);
  1370.     UNTIL (Life<0) OR (Level>MaxLevel);
  1371.   UNTIL Restart=FALSE;
  1372. END;
  1373.  
  1374. BEGIN                                   (* Hauptprogramm *)
  1375.   Init;
  1376.   Pictures;
  1377.   GlobHelp;
  1378.   Logo;
  1379.   Start;
  1380.   CloseGraph;
  1381.   RestoreCrtMode;
  1382. END.
  1383. (* ------------------------------------------------------ *)
  1384. (*                  Ende von BOLO.PAS                     *)
  1385.