home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 10 / ldm / hexbang.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-08-07  |  22.4 KB  |  975 lines
  1. (* ------------------------------------------------------ *)
  2. (*                       HEXBANGER                        *)
  3. (*           Warnung: Nichts fuer Ungeduldige!            *)
  4. (*           (c) 1989 Gustav Kaiser & TOOLBOX             *)
  5. (* ------------------------------------------------------ *)
  6. PROGRAM Hex_Banger;
  7. USES
  8.   Graph,Crt;
  9.  
  10. TYPE
  11.   FieldType = ARRAY[0..10,0..5] OF BYTE;
  12.   RadType   = ARRAY[0..8,0..4] OF RECORD
  13.                 LoX : INTEGER;
  14.                 LoY : INTEGER;
  15.                 FarbX : ARRAY[1..6] OF BYTE;
  16.                 FarbY : ARRAY[1..6] OF BYTE;
  17.               END;
  18.  
  19.  
  20.   CoordType = ARRAY[0..10,0..5] OF RECORD
  21.                 TriangleX : WORD;
  22.                 TriangleY : WORD;
  23.                 TriangleTop : BOOLEAN;
  24.               END;
  25.   TriangleType = ARRAY[0..3] OF PointType;
  26.   StoneType = ARRAY[1..6] OF RECORD
  27.                 RandF : BYTE;
  28.                 FillF : BYTE;
  29.                 FillT : BYTE;
  30.               END;
  31.   ScreenType = ARRAY[1..$3fff] OF BYTE;
  32.  
  33. CONST
  34.   _black = 0;
  35.   _green = 1;
  36.   _red = 2;
  37.   _yellow = 3;
  38.   Left = -1;
  39.   Right = 1;
  40.   Upper=TRUE;
  41.   Lower=FALSE;
  42.   LTLength=38;         (* Large Triangle Baselength *)
  43.   STLength=24;         (* Short Triangle Baselength *)
  44.   HexX = 20;
  45.   HexY = 1;
  46.   HexCol = _green;
  47.   CurCol = _yellow;
  48.   BackCol = _black;
  49.   Title = 'HEXBANGER';
  50.   HelpLines = 14;
  51.   HLine: ARRAY[1..HelpLines] OF STRING =
  52.     ( ' HEXBANGER (c) G. Kaiser & TOOLBOX',
  53.       ' ',
  54.       ' Ziel des Spiels ist es, den Aus- ',
  55.       ' gangszustand wieder herzustellen.',
  56.       ' ',
  57.       ' Cursorblockbelegung:',
  58.       ' 7 8 9',
  59.       ' 4   6  Cursor steuern',
  60.       ' 1 2 3',
  61.       ' 0   - Hex um ein Segment drehen',
  62.       ' .   - Drehrichtung aendern',
  63.       ' F10 - "Sound"  Aus/Ein',
  64.       ' ',
  65.       '      **** Bitte Taste ****' );
  66.   OrgField: FieldType =
  67.     ( (0,0,6,5,0,0),
  68.       (0,6,6,5,5,0),
  69.       (6,6,6,5,5,5),
  70.       (1,6,6,5,5,4),
  71.       (1,1,6,5,4,4),
  72.       (1,1,1,4,4,4),
  73.       (1,1,2,3,4,4),
  74.       (1,2,2,3,3,4),
  75.       (2,2,2,3,3,3),
  76.       (0,2,2,3,3,0),
  77.       (0,0,2,3,0,0) );
  78.   RadErl: ARRAY[0..8,0..4] OF BYTE =
  79.     ( (0,0,1,0,0),
  80.       (0,1,0,1,0),
  81.       (1,0,1,0,1),
  82.       (0,1,0,1,0),
  83.       (1,0,1,0,1),
  84.       (0,1,0,1,0),
  85.       (1,0,1,0,1),
  86.       (0,1,0,1,0),
  87.       (0,0,1,0,0) );
  88.   ColCoord: ARRAY[0..227] OF BYTE =
  89.     ( 3,0,4,0,4,1,3,1,2,1,2,0,
  90.       5,0,6,0,6,1,5,1,4,1,4,0,
  91.       7,0,8,0,8,1,7,1,6,1,6,0,
  92.       2,1,3,1,3,2,2,2,1,2,1,1,
  93.       4,1,5,1,5,2,4,2,3,2,3,1,
  94.       6,1,7,1,7,2,6,2,5,2,5,1,
  95.       8,1,9,1,9,2,8,2,7,2,7,1,
  96.       1,2,2,2,2,3,1,3,0,3,0,2,
  97.       3,2,4,2,4,3,3,3,2,3,2,2,
  98.       5,2,6,2,6,3,5,3,4,3,4,2,
  99.       7,2,8,2,8,3,7,3,6,3,6,2,
  100.       9,2,10,2,10,3,9,3,8,3,8,2,
  101.       2,3,3,3,3,4,2,4,1,4,1,3,
  102.       4,3,5,3,5,4,4,4,3,4,3,3,
  103.       6,3,7,3,7,4,6,4,5,4,5,3,
  104.       8,3,9,3,9,4,8,4,7,4,7,3,
  105.       3,4,4,4,4,5,3,5,2,5,2,4,
  106.       5,4,6,4,6,5,5,5,4,5,4,4,
  107.       7,4,8,4,8,5,7,5,6,5,6,4 );
  108.  
  109.  
  110. VAR
  111.   SoftScreen    : ScreenType;
  112.   HardScreen    : ScreenType ABSOLUTE $b800:$000;
  113.   DHoehe        : BYTE;
  114.   DLHalbe       : BYTE;
  115.   PlayField     : FieldType;
  116.   DpX,DpY       : WORD;
  117.   TriangleCoord : CoordType;
  118.   Wheel         : RadType;
  119.   CurX,CurY     : WORD;
  120.   CurXp,CurYp   : BYTE;
  121.   TurnRight     : BOOLEAN;
  122.   ArcCo         : ArcCoordsType;
  123.   STriangleTU   : TriangleType; (*Short Triangle Top Up  *)
  124.   STriangleTD   : TriangleType; (*Short Triangle Top Down*)
  125.   LTriangleTU   : TriangleType; (*Large Triangle Top Up  *)
  126.   LTriangleTD   : TriangleType; (*Large Triangle Top Down*)
  127.   Stone         : StoneType;
  128.   Level         : WORD;
  129.   SoundOn       : BOOLEAN;
  130.   StartTime     : LONGINT;
  131.   EndTime       : LONGINT;
  132.   Time          : LONGINT ABSOLUTE $40:$6C;
  133.  
  134. PROCEDURE GInit;
  135.  
  136. VAR
  137.   Driver,Mode : INTEGER;
  138.  
  139. BEGIN
  140.   Driver := CGA;
  141.   Mode := CGAC2;
  142.   InitGraph(Driver,Mode,'');
  143.   DirectVideo := FALSE;
  144. END;
  145.  
  146. PROCEDURE IVars;
  147.  
  148. VAR
  149.   x,y : BYTE;
  150.   TrHei,TrHalf: BYTE;
  151.  
  152. BEGIN
  153.   FOR x:=0 TO 10 DO FOR y:=0 TO 5 DO BEGIN
  154.     WITH TriangleCoord[x,y] DO BEGIN
  155.       TriangleX := 0;
  156.       TriangleY := 0;
  157.     END;
  158.   END;
  159.   CurXp := 2;
  160.   CurYp := 0;
  161.   DHoehe := Trunc(Sqrt(Sqr(LTLength)-Sqr(LTLength/2)));
  162.   DLHalbe := LTLength DIV 2;
  163.   TrHei := Trunc(Sqrt(Sqr(STLength)-Sqr(STLength/2)));
  164.   TrHalf := STLength DIV 2;
  165. (* Grund-Coordinaten für die Spielsteine (Top up) *)
  166.   STriangleTU[0].x := TrHalf; STriangleTU[0].y := 0;
  167.   STriangleTU[1].x := 0; STriangleTU[1].y := TrHei;
  168.   STriangleTU[2].x := STLength; STriangleTU[2].y := TrHei;
  169.   STriangleTU[3] := STriangleTU[0];
  170. (* Grund-Coordinaten für die Spielsteine (Top down) *)
  171.   STriangleTD[0].x := 0; STriangleTD[0].y := 0;
  172.   STriangleTD[1].x := TrHalf; STriangleTD[1].y := TrHei;
  173.   STriangleTD[2].x := STLength; STriangleTD[2].y := 0;
  174.   STriangleTD[3] := STriangleTD[0];
  175. (* Dreieckeigenschaften festlegen *)
  176. (* Grund-Coordinaten für die Spielfeld (Top up) *)
  177.   LTriangleTU[0].x := DLHalbe; LTriangleTU[0].y := 0;
  178.   LTriangleTU[1].x := 0; LTriangleTU[1].y := DHoehe;
  179.   LTriangleTU[2].x := LTLength; LTriangleTU[2].y := DHoehe;
  180.   LTriangleTU[3] := LTriangleTU[0];
  181. (* Grund-Coordinaten für die LpielFeld (Top down) *)
  182.   LTriangleTD[0].x := 0; LTriangleTD[0].y := 0;
  183.   LTriangleTD[1].x := DLHalbe; LTriangleTD[1].y := DHoehe;
  184.   LTriangleTD[2].x := LTLength; LTriangleTD[2].y := 0;
  185.   LTriangleTD[3] := LTriangleTD[0];
  186. (* Dreieckeigenschaften festlegen *)
  187.   Stone[1].RandF := _red;
  188.   Stone[1].FillF := _red;
  189.   Stone[1].FillT := SolidFill;
  190.   Stone[2].RandF := _green;
  191.   Stone[2].FillF := _green;
  192.   Stone[2].FillT := CloseDotFill;
  193.   Stone[3].RandF := _yellow;
  194.   Stone[3].FillF := _yellow;
  195.   Stone[3].FillT := SolidFill;
  196.   Stone[4].RandF := _red;
  197.   Stone[4].FillF := _red;
  198.   Stone[4].FillT := CloseDotFill;
  199.   Stone[5].RandF := _green;
  200.   Stone[5].FillF := _green;
  201.   Stone[5].FillT := SolidFill;
  202.   Stone[6].RandF := _yellow;
  203.   Stone[6].FillF := _yellow;
  204.   Stone[6].FillT := CloseDotFill;
  205.   PlayField := OrgField;
  206.   DpX := 0;
  207.   DpY := 0;
  208.   TurnRight := TRUE;
  209.   SoundOn   := TRUE;
  210. END;
  211.  
  212. PROCEDURE DrawOrgHex(x,y: WORD);
  213.  
  214. BEGIN
  215.   SetColor(_green);
  216.   MoveTo(x,y);
  217.   LineRel(LTLength,0);
  218.   LineRel(DLHalbe,DHoehe);
  219.   LineRel(-DLHalbe,DHoehe);
  220.   LineRel(-LTLength,0);
  221.   LineRel(-DLHalbe,-DHoehe);
  222.   LineRel(DLHalbe,-DHoehe);
  223.   LineRel(LTLength,DHoehe*2);
  224.   MoveRel(-LTLength,0);
  225.   LineRel(LTLength,DHoehe*-2);
  226.   MoveRel(DLHalbe,DHoehe);
  227.   LineRel(LTLength*-2,0);
  228.   SetFillStyle(SolidFill,_red);
  229.   FloodFill(x+2,y+2,_green);
  230.   SetFillStyle(CloseDotFill,_green);
  231.   FloodFill(x+37,y+6,_green);
  232.   SetFillStyle(SolidFill,_yellow);
  233.   FloodFill(x+37,y+36,_green);
  234.   SetFillStyle(CloseDotFill,_red);
  235.   FloodFill(x+22,y+46,_green);
  236.   SetFillStyle(SolidFill,_green);
  237.   FloodFill(x+2,y+36,_green);
  238.   SetFillStyle(CloseDotFill,_yellow);
  239.   FloodFill(x+1,y+4,_green);
  240. END;
  241.  
  242. PROCEDURE DrawLogo;
  243.  
  244. VAR
  245.   i     : BYTE;
  246.   Ch    : STRING[1];
  247.   x,y   : WORD;
  248.  
  249.  
  250. BEGIN
  251.   SetTextStyle(DefaultFont,HorizDir,2);
  252.   SetTextJustify(LeftText,TopText);
  253.   x := 290; y := 20;
  254.   FOR i := 1 TO Length(Title) DO BEGIN
  255.     Ch := Copy(Title,i,1);
  256.     SetColor(_yellow);
  257.     OutTextXY(x,y,Ch);
  258.     SetColor(_red);
  259.     OutTextXY(x+2,y-2,Ch);
  260.     y := y + TextHeight(Ch)+3;
  261.   END;
  262.   DrawOrgHex(226,124);
  263. END;
  264.  
  265. PROCEDURE Print(x,y:WORD; Msg:STRING; Shadow,Col,Size,
  266.                Cent: BYTE);
  267. BEGIN
  268.   SetTextStyle(DefaultFont,HorizDir,Size);
  269.   SetColor(Shadow);
  270.   IF Cent=1 THEN x:= (319 - TextWidth(Msg)) DIV 2;
  271.   OutTextXY(x-1,y+1,Msg);
  272.   SetColor(Col);
  273.   OutTextXY(x,y,Msg);
  274. END;
  275.  
  276. PROCEDURE TitleScreen;
  277.  
  278. VAR
  279.   s,x : WORD;
  280.   p   : POINTER;
  281.   i   : BYTE;
  282.  
  283. BEGIN
  284.   SetTextJustify(LeftText,TopText);
  285.   SetViewPort(0,0,319,199,ClipOff);
  286.   Print(0,8,Title,_yellow,_red,4,CenterText);
  287.   DrawOrgHex(20,40);
  288.   s:=ImageSize(0,0,2*LTLength,2*DHoehe);
  289.   GetMem(p,s);
  290.   GetImage(0,40,2*LTLength,2*DHoehe+40,p^);
  291.   x:=2*LTLength;
  292.   FOR i:=0 TO 4 DO BEGIN
  293.     PutImage(x,40,p^,OrPut);
  294.     x:=x+2*LTLength;
  295.   END;
  296.   Print(0,180,'V1.0  (c) 1989 by Kaiser Gustav',_red,_green,
  297.         1,CenterText);
  298.   Print(0,110,'F1 - Anleitung',_yellow,_green,2,CenterText);
  299.   Print(0,130,'F2 - Spielen  ',_yellow,_green,2,CenterText);
  300.   Print(0,150,'F3 - Ende     ',_yellow,_green,2,CenterText);
  301.   FreeMem(p,s);
  302. END;
  303.  
  304. PROCEDURE Toggle(VAR BoVar: BOOLEAN);
  305.  
  306. BEGIN
  307.   IF BoVar THEN BoVar := FALSE ELSE BoVar := TRUE;
  308. END;
  309.  
  310. PROCEDURE SoundFine;
  311.  
  312. VAR
  313.   Frequ : WORD;
  314.  
  315. BEGIN
  316.   IF SoundOn THEN BEGIN
  317.     Frequ := 220;
  318.     REPEAT
  319.       Sound(Frequ);
  320.       Frequ:=Frequ+1;
  321.     UNTIL Frequ>880;
  322.     NoSound;
  323.   END;
  324. END;
  325.  
  326. PROCEDURE SoundBad;
  327.  
  328. VAR
  329.   Frequ : REAL;
  330.  
  331. BEGIN
  332.   IF SoundOn THEN BEGIN
  333.     Frequ := 440;
  334.     REPEAT
  335.       Sound(Trunc(Frequ));
  336.       Frequ:=Frequ-0.5;
  337.     UNTIL Frequ<10;
  338.     NoSound;
  339.   END;
  340. END;
  341.  
  342. PROCEDURE SoundTurn;
  343.  
  344. VAR
  345.   Frequ : REAL;
  346.  
  347. BEGIN
  348.   IF SoundOn THEN BEGIN
  349.     Frequ := 330;
  350.     REPEAT
  351.       Sound(Trunc(Frequ));
  352.       Frequ := Frequ+0.5;
  353.     UNTIL Frequ>550;
  354.     REPEAT
  355.       Frequ := Frequ-1;
  356.       Sound(Trunc(Frequ));
  357.     UNTIL Frequ<330;
  358.     NoSound;
  359.   END;
  360. END;
  361.  
  362. PROCEDURE SoundReady;
  363.  
  364. VAR
  365.   Frequ : REAL;
  366.   i     : BYTE;
  367.  
  368. BEGIN
  369.   FOR i := 0 TO 2 DO BEGIN
  370.     Frequ := 220;
  371.     REPEAT
  372.       Sound(Trunc(Frequ));
  373.       Frequ:=Frequ+0.3;
  374.     UNTIL Frequ>880;
  375.   END;
  376.   NoSound;
  377. END;
  378.  
  379. PROCEDURE Help;
  380.  
  381. VAR
  382.   i  : BYTE;
  383.   Ch : CHAR;
  384.   y  : WORD;
  385.  
  386. BEGIN
  387.   SoftScreen := HardScreen;
  388.   SetViewPort(20,20,299,179,ClipOn);
  389.   ClearViewPort;
  390.   y := 2;
  391.   FOR i:=1 TO HelpLines DO BEGIN
  392.     Print(2,y,HLine[i],_yellow,_red,1,LeftText);
  393.     y := y + TextHeight(HLine[i])+2;
  394.   END;
  395.   SetViewPort(0,0,319,199,ClipOff);
  396.   Ch := ReadKey;
  397.   IF Ch=#0 THEN Ch := ReadKey;
  398.   HardScreen := SoftScreen;
  399. END;
  400.  
  401. PROCEDURE DrawOneStone(xT,yT:WORD; Number: BYTE;
  402.                                    TriTop:BOOLEAN);
  403.  
  404. VAR
  405.   TempTria : TriangleType;
  406.   i        : BYTE;
  407.  
  408. BEGIN
  409.   WITH Stone[Number] DO BEGIN
  410.     IF TriTop THEN TempTria := STriangleTU
  411.       ELSE TempTria:= STriangleTD;
  412.     FOR i := 0 TO 3 DO BEGIN
  413.       WITH TempTria[i] DO BEGIN
  414.         x := x + xT;
  415.         y := y + yT;
  416.       END;
  417.     END;
  418.     SetColor(RandF);
  419.     SetFillStyle(FillT,FillF);
  420.     FillPoly(4,TempTria);
  421.   END;
  422. END;
  423.  
  424. PROCEDURE DrawOneField(xT,yT:WORD; ActTop:BOOLEAN);
  425.  
  426. VAR
  427.   TempTria : TriangleType;
  428.   i        : BYTE;
  429.  
  430. BEGIN
  431.   IF ActTop THEN TempTria := LTriangleTU
  432.     ELSE TempTria:= LTriangleTD;
  433.   FOR i := 0 TO 3 DO BEGIN
  434.     WITH TempTria[i] DO BEGIN
  435.       x := x + xT;
  436.       y := y + yT - 32;
  437.     END;
  438.   END;
  439.   SetFillStyle(EmptyFill,BackCol);
  440.   FillPoly(4,TempTria);
  441. END;
  442.  
  443. PROCEDURE DrawOneRow(x1,y1:WORD; Anz,Sb:BYTE;
  444.                                  ActTop:BOOLEAN);
  445.  
  446. VAR
  447.   i : BYTE;
  448.  
  449. BEGIN
  450.   DpX := Sb;
  451.   IF (Sb AND $fe) = 1 THEN Toggle(ActTop);
  452.   FOR i := 1 TO Anz DO BEGIN
  453.     WITH TriangleCoord[DpX,DpY] DO BEGIN
  454.       TriangleX := x1+7;
  455.       TriangleY := y1-26;
  456.       TriangleTop := ActTop;
  457.     END;
  458.     DrawOneField(x1,y1,ActTop);
  459.     Toggle(ActTop);
  460.     x1:=x1+DLHalbe;
  461.     Inc(DpX);
  462.   END;
  463.   Inc(DpY);
  464.   DpX := 0;
  465. END;
  466.  
  467. PROCEDURE SetTurnDir;
  468.  
  469. VAR
  470.   Col1,Col2 : BYTE;
  471.  
  472. BEGIN
  473.   SetLineStyle(SolidLn,0,ThickWidth);
  474.   Col1:=0; Col2:=0;
  475.   IF TurnRight THEN Col1 := HexCol ELSE Col2:= HexCol;
  476.   SetColor(Col1);
  477.   MoveTo(ArcCo.XStart+5,ArcCo.Ystart-1);
  478.   LineRel(-4,3);
  479.   LineRel(-3,-4);
  480.   SetColor(Col2);
  481.   MoveTo(ArcCo.Xend+4,ArcCo.Yend-3);
  482.   LineRel(-2,5);
  483.   LineRel(-6,-3);
  484.   SetLineStyle(SolidLn,0,NormWidth);
  485. END;
  486.  
  487. PROCEDURE SetCursor(xp,yp,Farbe: BYTE);
  488.  
  489. VAR
  490.   x,y : INTEGER;
  491.  
  492. BEGIN
  493.   x := Wheel[xp,yp].LoX;
  494.   y := Wheel[xp,yp].LoY;
  495.   SetColor(Farbe);
  496.   MoveTo(x,y);
  497.   LineRel(LTLength,0);
  498.   LineRel(DLHalbe,DHoehe);
  499.   LineRel(-DLHalbe,DHoehe);
  500.   LineRel(-LTLength,0);
  501.   LineRel(-DLHalbe,-DHoehe);
  502.   LineRel(DLHalbe,-DHoehe);
  503.   LineRel(LTLength,DHoehe*2);
  504.   MoveRel(-LTLength,0);
  505.   LineRel(LTLength,DHoehe*-2);
  506.   MoveRel(DLHalbe,DHoehe);
  507.   LineRel(LTLength*-2,0);
  508. END;
  509.  
  510. PROCEDURE DrawHexagon(Sx,Sy:WORD; f: BYTE);
  511.  
  512. VAR
  513.   x1,y1 : WORD;
  514.   SichtBar : BYTE;
  515.   Anzahl : BYTE;
  516.   i   : INTEGER;
  517.   ActTop  : BOOLEAN;
  518.  
  519. BEGIN
  520.   DrawLogo;
  521.   Print(208,16,'Zug:   0',_green,_red,1,LeftText);
  522.   SetColor(f);
  523.   x1:=Sx+DLHalbe;
  524.   y1:=Sy+DHoehe;
  525.   SichtBar:= 2;
  526.   Anzahl := 7;
  527.   FOR i:= 1 TO 3 DO BEGIN
  528.     DrawOneRow(x1,y1,Anzahl,SichtBar,Upper);
  529.     y1:=y1+DHoehe;
  530.     x1:=x1-DLHalbe;
  531.     IF SichtBar>0 THEN Dec(SichtBar);
  532.     Anzahl:=Anzahl+2;
  533.   END;
  534.   SichtBar := 0;
  535.   FOR i:=1 TO 3 DO BEGIN
  536.     x1:=x1+DLHalbe;
  537.     Anzahl:=Anzahl-2;
  538.     DrawOneRow(x1,y1,Anzahl,SichtBar,Lower);
  539.     Inc(SichtBar);
  540.     y1:=y1+DHoehe;
  541.   END;
  542.   Arc(20,180,320,220,10);
  543.   GetArcCoords(ArcCo);
  544.   SetTurnDir;
  545. END;
  546.  
  547. PROCEDURE DrawTriangles;
  548.  
  549. VAR
  550.   x,y : BYTE;
  551.   x1,y1 : INTEGER;
  552.   a:CHAR;
  553.  
  554. BEGIN
  555.   SetColor(2);
  556.   FOR y := 0 TO 5 DO BEGIN
  557.     FOR x := 0 TO 10 DO BEGIN
  558.       WITH TriangleCoord[x,y] DO BEGIN
  559.         IF PlayField[x,y] <> 0 THEN BEGIN
  560.           DrawOneStone(TriangleX,TriangleY,PlayField[x,y],
  561.                        TriangleTop);
  562.         END;
  563.       END;
  564.     END;
  565.   END;
  566. END;
  567.  
  568.  
  569. PROCEDURE InitWheel;
  570.  
  571. VAR
  572.   RadX,RadY : BYTE;
  573.   DrX,DrY   : BYTE;
  574.   x,y       : INTEGER;
  575.   CoordP    : BYTE;
  576.   i         : BYTE;
  577.  
  578. BEGIN
  579.   x := HexX;
  580.   y := HexY;
  581.   CoordP := 0;
  582.   FOR RadY := 0 TO 4 DO BEGIN
  583.     FOR RadX := 0 TO 8 DO BEGIN
  584.       WITH Wheel[RadX,RadY] DO BEGIN
  585.         IF(RadErl[RadX,RadY] = 1) THEN BEGIN
  586.           LoX := x;
  587.           LoY := y;
  588.           FOR i:=1 TO 6 DO BEGIN
  589.             FarbX[i] := ColCoord[CoordP];
  590.             FarbY[i] := ColCoord[CoordP+1];
  591.             Inc(CoordP,2);
  592.           END;
  593.         END;
  594.       END;
  595.       x := x + DLHalbe;
  596.     END;
  597.     x := HexX;
  598.     y := y + DHoehe;
  599.   END;
  600. END;
  601.  
  602. FUNCTION GetCoords: BOOLEAN;
  603.  
  604. VAR
  605.   Ch : CHAR;
  606.   Ende  : BOOLEAN;
  607.   ToggleCounter : REAL;
  608.   BlinkCol      : BYTE;
  609.  
  610. BEGIN
  611.   ToggleCounter := 0;
  612.   BlinkCol := _black;
  613.   Ende := FALSE;
  614.   REPEAT
  615.     REPEAT
  616.       ToggleCounter:=ToggleCounter+0.5;
  617.       IF ToggleCounter>1000 THEN BEGIN
  618.         SetCursor(CurXp,CurYp,BlinkCol);
  619.         IF BlinkCol = CurCol THEN BlinkCol := _black
  620.           ELSE BlinkCol := CurCol;
  621.         ToggleCounter := 0;
  622.       END;
  623.     UNTIL KeyPressed;
  624.     SetCursor(CurXp,CurYp,CurCol);
  625.     Ch := ReadKey;
  626.     IF Ch=#0 THEN Ch:=ReadKey ELSE Ch:=#0;
  627.     CASE Ch OF
  628.       'P': BEGIN (* Down *)
  629.              SetCursor(CurXp,CurYp,HexCol);
  630.              REPEAT
  631.                IF CurYp < 4 THEN Inc(CurYp) ELSE CurYp:=0;
  632.              UNTIL RadErl[CurXp,CurYp]=1;
  633.              SetCursor(CurXp,CurYp,CurCol);
  634.            END;
  635.       'H': BEGIN (* Up *)
  636.              SetCursor(CurXp,CurYp,HexCol);
  637.              REPEAT
  638.                IF CurYp>0 THEN Dec(CurYp) ELSE CurYp:=4;
  639.              UNTIL RadErl[CurXp,CurYp]=1;
  640.              SetCursor(CurXp,CurYp,CurCol);
  641.            END;
  642.       'M': BEGIN (* Right *)
  643.              SetCursor(CurXp,CurYp,HexCol);
  644.              REPEAT
  645.                IF CurXp<8 THEN Inc(CurXp) ELSE CurXp:=0;
  646.              UNTIL RadErl[CurXp,CurYp]=1;
  647.              SetCursor(CurXp,CurYp,CurCol);
  648.            END;
  649.       'K': BEGIN (* Left *)
  650.              SetCursor(CurXp,CurYp,HexCol);
  651.              REPEAT
  652.                IF CurXp>0 THEN Dec(CurXp) ELSE CurXp:=8;
  653.              UNTIL RadErl[CurXp,CurYp]=1;
  654.              SetCursor(CurXp,CurYp,CurCol);
  655.            END;
  656.       'Q': BEGIN (* Right and Down *)
  657.              SetCursor(CurXp,CurYp,HexCol);
  658.              REPEAT
  659.                IF CurXp<8 THEN Inc(CurXp) ELSE CurXp:=0;
  660.                IF CurYp<4 THEN Inc(CurYp) ELSE CurYp:=0;
  661.              UNTIL RadErl[CurXp,CurYp]=1;
  662.              SetCursor(CurXp,CurYp,CurCol);
  663.            END;
  664.       'G': BEGIN (* Left and Up *)
  665.              SetCursor(CurXp,CurYp,HexCol);
  666.              REPEAT
  667.                IF CurXp>0 THEN Dec(CurXp) ELSE CurXp:=8;
  668.                IF CurYp>0 THEN Dec(CurYp) ELSE CurYp:=4;
  669.              UNTIL RadErl[CurXp,CurYp]=1;
  670.              SetCursor(CurXp,CurYp,CurCol);
  671.            END;
  672.       'I': BEGIN (* Right and Up *)
  673.              SetCursor(CurXp,CurYp,HexCol);
  674.              REPEAT
  675.                IF CurXp<8 THEN Inc(CurXp) ELSE CurXp:=0;
  676.                IF CurYp>0 THEN Dec(CurYp) ELSE CurYp:=4;
  677.              UNTIL RadErl[CurXp,CurYp]=1;
  678.              SetCursor(CurXp,CurYp,CurCol);
  679.            END;
  680.       'O': BEGIN (* Down & Left *)
  681.              SetCursor(CurXp,CurYp,HexCol);
  682.              REPEAT
  683.                IF CurXp>0 THEN Dec(CurXp) ELSE CurXp:=8;
  684.                IF CurYp<4 THEN Inc(CurYp) ELSE CurYp:=0;
  685.              UNTIL RadErl[CurXp,CurYp]=1;
  686.              SetCursor(CurXp,CurYp,CurCol);
  687.            END;
  688.       'S': BEGIN (* Change Turndir *)
  689.              Toggle(TurnRight);
  690.              SetTurnDir;
  691.              SoundFine;
  692.            END;
  693.       'R': BEGIN
  694.              Ende := TRUE;
  695.              GetCoords := TRUE;
  696.            END;
  697.       '=': BEGIN
  698.              Ende := TRUE;
  699.              GetCoords := FALSE;
  700.            END;
  701.       'D': Toggle(SoundOn);
  702.       ';': Help;
  703.       ELSE SoundBad;
  704.     END;
  705.   UNTIL Ende;
  706. END;
  707.  
  708. PROCEDURE TurnWheel;
  709.  
  710. VAR
  711.   Cols  : ARRAY[1..6] OF BYTE;
  712.   i,Hlp : BYTE;
  713.  
  714. BEGIN
  715.   WITH Wheel[CurXp,CurYp] DO BEGIN
  716.     FOR i := 1 TO 6 DO
  717.       Cols[i]:=PlayField[FarbX[i],FarbY[i]];
  718.     IF TurnRight THEN BEGIN
  719.       Hlp := Cols[6];
  720.       FOR i := 6 DOWNTO 2 DO Cols[i] := Cols[i-1];
  721.       Cols[1] := Hlp;
  722.     END
  723.     ELSE BEGIN
  724.       Hlp := Cols[1];
  725.       FOR i := 1 TO 5 DO Cols[i] := Cols[i+1];
  726.       Cols[6] := Hlp;
  727.     END;
  728.     FOR i := 1 TO 6 DO
  729.       PlayField[FarbX[i],FarbY[i]] := Cols[i];
  730.   END;
  731. END;
  732.  
  733. PROCEDURE DrawWheel;
  734.  
  735. VAR
  736.   i : BYTE;
  737.  
  738. BEGIN
  739.   WITH Wheel[CurXp,CurYp] DO BEGIN
  740.     FOR i:=1 TO 6 DO BEGIN
  741.       WITH TriangleCoord[FarbX[i],FarbY[i]] DO BEGIN
  742.         DrawOneStone(TriangleX,TriangleY,
  743.           PlayField[FarbX[i],FarbY[i]],TriangleTop);
  744.       END;
  745.     END;
  746.   END;
  747. END;
  748.  
  749. FUNCTION TestIfComplete: BOOLEAN;
  750.  
  751. VAR
  752.   x,y : BYTE;
  753.  
  754. BEGIN
  755.   FOR x:=0 TO 10 DO BEGIN
  756.     FOR y:=0 TO 5 DO BEGIN
  757.       IF PlayField[x,y]<>OrgField[x,y] THEN BEGIN
  758.         TestIfComplete:=FALSE;
  759.         Exit;
  760.       END;
  761.     END;
  762.   END;
  763.   TestIfComplete:=TRUE
  764. END;
  765.  
  766. FUNCTION GetKey: CHAR;
  767.  
  768. VAR
  769.   Ch : CHAR;
  770.  
  771. BEGIN
  772.   REPEAT
  773.     Ch := ReadKey;
  774.     IF Ch<>#0 THEN BEGIN
  775.       SoundBad;
  776.       Ch:=#0;
  777.     END
  778.     ELSE Ch := ReadKey;
  779.   UNTIL Ch<>#0;
  780.   GetKey := Ch;
  781. END;
  782.  
  783. PROCEDURE GetNumber;
  784.  
  785. VAR
  786.   x,y  : WORD;
  787.   Nbr  : BYTE;
  788.   Temp : STRING;
  789.   Ende : BOOLEAN;
  790.   Ch   : CHAR;
  791.   Err  : INTEGER;
  792.  
  793. BEGIN
  794.   SetTextStyle(SmallFont,HorizDir,4);
  795.   SetColor(_red);
  796.   OutTextXY(4,4,'Level:');
  797.   Temp:='_'; x := 40; y := 4; Ende := FALSE; Nbr := 0;
  798.   OutTextXY(x,y,Temp);
  799.   REPEAT
  800.     Ch := ReadKey;
  801.     CASE Ch OF
  802.       '0'..'9': BEGIN
  803.                   IF Nbr<4 THEN BEGIN
  804.                     SetColor(_black);
  805.                     OutTextXY(x,y,Temp);
  806.                     Delete(Temp,Length(Temp),1);
  807.                     Temp:=Temp+Ch+'_';
  808.                     SetColor(_red);
  809.                     OutTextXY(x,y,Temp);
  810.                     Inc(Nbr);
  811.                   END
  812.                   ELSE SoundBad;
  813.                 END;
  814.       #8:  BEGIN
  815.              IF Nbr>0 THEN BEGIN
  816.                SetColor(_black);
  817.                OutTextXY(x,y,Temp);
  818.                Delete(Temp,Length(Temp)-1,2);
  819.                Temp:=Temp+'_';
  820.                SetColor(_red);
  821.                OutTextXY(x,y,Temp);
  822.                Dec(Nbr);
  823.              END
  824.              ELSE SoundBad;
  825.            END;
  826.       #13: BEGIN
  827.              IF Nbr>0 THEN BEGIN
  828.                Delete(Temp,Length(Temp),1);
  829.                Val(Temp,Level,Err);
  830.                IF Level > 3 THEN Ende:= TRUE
  831.                  ELSE BEGIN
  832.                    Temp:=Temp+'_';
  833.                    SoundBad;
  834.                  END;
  835.              END
  836.              ELSE SoundBad;
  837.            END;
  838.       ELSE SoundBad;
  839.     END;
  840.   UNTIL Ende;
  841. END;
  842.  
  843. PROCEDURE ShuffleWheel;
  844.  
  845. VAR
  846.   i : WORD;
  847.   j,h : BYTE;
  848.  
  849. BEGIN
  850.   Randomize;
  851.   FOR i := 1 TO Level DO BEGIN
  852.     REPEAT
  853.       CurXp := Random(9);
  854.       CurYp := Random(5);
  855.     UNTIL RadErl[CurXp,CurYp]<>0;
  856.     IF Random(1) = 0 THEN TurnRight:=TRUE
  857.       ELSE TurnRight:=FALSE;
  858.     h := Random(3)+1;
  859.     FOR j:=1 TO h DO TurnWheel;
  860.   END;
  861. END;
  862.  
  863. PROCEDURE GetLevel;
  864.  
  865. BEGIN
  866.   SoftScreen := HardScreen;
  867.   SetViewPort(40,120,120,140,ClipOn);
  868.   ClearViewPort;
  869.   GetNumber;
  870.   ClearViewPort;
  871.   OutTextXY(8,4,'Bitte warten');
  872.   SetViewPort(0,0,319,199,ClipOff);
  873.   ShuffleWheel;
  874.   HardScreen := SoftScreen;
  875.   DrawTriangles;
  876. END;
  877.  
  878. PROCEDURE ShowMoves(Mov: WORD);
  879.  
  880. VAR
  881.   Temp : STRING;
  882.  
  883. BEGIN
  884.   Dec(Mov);
  885.   Str(Mov:4,Temp);
  886.   Print(240,16,Temp,_black,_black,1,LeftText);
  887.   Inc(Mov);
  888.   Str(Mov:4,Temp);
  889.   Print(240,16,Temp,_green,_red,1,LeftText);
  890. END;
  891.  
  892. PROCEDURE ShowTime;
  893.  
  894. VAR
  895.   Hou,Min,Sec : BYTE;
  896.   s1,s2,s3    : STRING;
  897.   Ch          : CHAR;
  898.  
  899. BEGIN
  900.   SetViewPort(8,80,311,98,ClipOn);
  901.   ClearViewPort;
  902.   SetColor(_yellow);
  903.   Rectangle(0,0,311-8,98-80);
  904.   Min := EndTime DIV 60;
  905.   Sec := EndTime-Min*60;
  906.   Hou := Min DIV 60;
  907.   Min := Min-Hou*60;
  908.   Str(Hou:2,s1);
  909.   Str(Min:2,s2);
  910.   Str(Sec:2,s3);
  911.   s1:=s1+':'+s2+':'+s3;
  912.   Print(2,6,'Geschafft !!! Zeit: '+s1,_green,_red,1,
  913.         CenterText);
  914.   Ch := ReadKey;
  915.   IF Ch = #0 THEN Ch := ReadKey;
  916.   SetViewPort(0,0,319,199,ClipOff);
  917. END;
  918.  
  919. PROCEDURE MainPlay;
  920.  
  921. VAR
  922.   Ready,
  923.   Ende   : BOOLEAN;
  924.   Fkey   : CHAR;
  925.   Moves  : WORD;
  926.  
  927. BEGIN
  928.   Ende := FALSE;
  929.   TitleScreen;
  930.   REPEAT
  931.     Fkey := GetKey;
  932.     CASE Fkey OF
  933.       '<': BEGIN
  934.              Moves:=0;
  935.              PlayField:=OrgField;
  936.              ClearViewPort;
  937.              CurXp := 2; CurYp := 0;
  938.              DpX := 0; DpY := 0;
  939.              TurnRight := TRUE;
  940.              DrawHexagon(HexX,HexY,HexCol);
  941.              DrawTriangles;
  942.              InitWheel;
  943.              GetLevel;
  944.              SetCursor(CurXp,CurYp,CurCol);
  945.              SetTurnDir;
  946.              StartTime := Time;
  947.              REPEAT
  948.                IF NOT GetCoords THEN Exit;
  949.                TurnWheel;
  950.                DrawWheel;
  951.                Inc(Moves);
  952.                ShowMoves(Moves);
  953.                SoundTurn;
  954.                Ready:=TestIfComplete;
  955.              UNTIL Ready;
  956.              EndTime := (Time-StartTime) DIV 18;
  957.              SoundReady;
  958.              ShowTime;
  959.              ClearViewPort;
  960.              TitleScreen;
  961.            END;
  962.       '=': Ende:=TRUE;
  963.       ';': Help;
  964.       ELSE SoundBad;
  965.     END;
  966.   UNTIL Ende;
  967. END;
  968.  
  969. BEGIN
  970.   GInit;
  971.   IVars;
  972.   MainPlay;
  973.   CloseGraph;
  974. END.
  975.