home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / cebit_91 / otashi / otashi.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1991-03-07  |  26.9 KB  |  822 lines
  1. (*========================================================*)
  2. (*                Otashi.Pas Version 2.11                 *)
  3. (*         (C) 1991 Volkmar Stegmann und toolbox          *)
  4. (*--------------------------------------------------------*)
  5. (*     Programmart:  Grafik-Knobelspiel                   *)
  6. (*     System:       MS-/PC-/DR-DOS ab 3.00,              *)
  7. (*                   OS/2-Kompatibilitätsbox              *)
  8. (*     Compiler:     Turbo Pascal ab V. 4.00              *)
  9. (*     benöt. Units: Drivers, Fonts bzw. BGIDriv, BGIFont *)
  10. (*                   für Turbo4 DOS_50 aus Toolbox 12'89  *)
  11. (*     Grafik:       EGA, VGA, Hercules                   *)
  12. (*     Hardware:     PC-XT/AT, Zwei- oder Dreitasten-Maus *)
  13. (*========================================================*)
  14.  
  15. {$B-,D+,L+,F-,I-,N-,R-,S+,V-,M 16384,0,655360}
  16. {$IFDEF VER60}  {$X+,G-}       {$ENDIF}
  17. {$IFNDEF VER40} {$A-,E-,O-,L+} {$ENDIF}
  18. {.$DEFINE internaldrivers} {bedingte Einbindung des Trei- }
  19. {$DEFINE internalfonts}    {bers und der Fonts in den Code}
  20. PROGRAM Otashi;
  21.  
  22. USES
  23. {$IFDEF VER60}    {Turbo Pascal 6.0}
  24.   {$IFDEF internaldrivers} BGIDriv, {$ENDIF}
  25.   {$IFDEF internalfonts}   BGIFont, {$ENDIF}
  26. {$ELSE}           {Turbo Pascal 4.0 bis 5.5}
  27.   {$IFDEF internaldrivers} Drivers, {$ENDIF}
  28.   {$IFDEF internalfonts}   Fonts,   {$ENDIF}
  29. {$ENDIF}
  30.   Crt, Dos,
  31.   {$IFDEF VER40}           DOS_50,  {$ENDIF}
  32.   Graph;
  33.  
  34. TYPE
  35.   String21    = STRING[21];
  36.   RegisterSet = RECORD
  37.     AX, BX, CX, DX, BP, DI, SI, DS, ES, Flags: INTEGER
  38.   END;
  39.   Array16     = ARRAY[1..6] OF INTEGER;
  40.  
  41. CONST
  42.   SStack     : Array16   = (1,  8, 15, 22, 29, 36);
  43.   Pos1       : Array16   = (1, 12,  1, 12,  6,  7);
  44.   Pos2       : Array16   = (1,  1,  8,  8,  4,  5);
  45.   FileHeader : String21  = #8'Otashi Score Liste'#0#26;
  46.   DoneFlag   : BOOLEAN   = FALSE;
  47.   version    : STRING[7] = 'V. 2.11';
  48.  
  49. VAR
  50.   ScoreFile              : PathStr;
  51.   ScoreFileDir           : DirStr;
  52.   ScoreFileName          : NameStr;
  53.   ScoreFileExt           : ExtStr;
  54.   i, j, Taste, Reihe, w,
  55.   n, u, s, t, x, y, z, q,
  56.   GraphDriver, GraphMode,
  57.   Reg1, Reg2, Reg3, Reg4,
  58.   XOld, YOld, XPos, YPos : INTEGER;
  59.   mode                   : ^BYTE;
  60.   Farben, Bilder         : ARRAY[0..36] OF INTEGER;
  61.   Stack                  : ARRAY[1..72] OF INTEGER;
  62.   HStack                 : ARRAY[-2..36] OF BYTE;
  63.   Punkte                 : LONGINT;
  64.   Feld                   : ARRAY[0..13, 0..9] OF INTEGER;
  65.   Farbe, Fill            : Array16;
  66.   Size                   : WORD;
  67.   b, a                   : String21;
  68.   Name                   : ARRAY[1..6] OF STRING[15];
  69.   tp                     : ARRAY[1..6] OF LONGINT;
  70.   Punkt                  : ARRAY[1..6] OF STRING[6];
  71.   Back2, Back            : Pointer;
  72.   Stein                  : ARRAY[1..36] OF Pointer;
  73.   sr                     : SearchRec;
  74.   Safe                   : FILE OF String21;
  75.   MonoMonitor, MenuFlag  : BOOLEAN;
  76.  
  77. (*--------------------------------------------------------*)
  78.  
  79. PROCEDURE GrundMuster(r: INTEGER);
  80. {            zeichnet das Grundmodell eines Steines        }
  81. BEGIN
  82.   SetColor(White);
  83.   Rectangle(0, 0, 40, 40);
  84.   SetFillStyle(Fill[r], Farbe[r]);
  85.   FloodFill(1, 1, White);
  86.   SetFillStyle(SolidFill, Black);
  87.   PieSlice(20, 20, 0, 360, 18);
  88.   SetColor(Black); Line(20, 20, 37, 20); SetColor(White);
  89.   Circle(20, 20, 18); Circle(20, 20, 16);
  90. END;
  91.  
  92. (*--------------------------------------------------------*)
  93.  
  94. PROCEDURE Muster(e, r: INTEGER);
  95. {        zeichnet eines der sechs Muster in den Stein      }
  96. BEGIN
  97.   CASE e OF
  98.   1: BEGIN
  99.        GrundMuster(r);
  100.        Arc(20, 14, 90, 270, 8); Arc(20, 26, 270, 90, 8);
  101.        Circle(20, 14, 3); Circle(20, 26, 3);
  102.        SetFillStyle(SolidFill, White);
  103.        FloodFill(25, 14, White); FloodFill(20, 26, White);
  104.        SetColor(Black); Circle(20, 14, 3); SetColor(Cyan);
  105.      END;
  106.   2: BEGIN
  107.        GrundMuster(r);
  108.        Circle(12, 20, 8); Circle(28, 20, 8);
  109.        Circle(12, 20, 3); Circle(28, 20, 3);
  110.        SetFillStyle(SolidFill, White);
  111.        FloodFill(6, 25, White); FloodFill(28, 25, White);
  112.        SetColor(Black);
  113.        Circle(28, 20, 3);
  114.        SetColor(Cyan);
  115.      END;
  116.   3: BEGIN
  117.        GrundMuster(r);
  118.        Arc(20, 14,  90, 270, 8); Arc(20, 26, 270,  90, 8);
  119.        Arc(12, 20, 180, 360, 8); Arc(28, 20, 360, 180, 8);
  120.      END;
  121.   4: BEGIN
  122.        GrundMuster(r); SetFillStyle(SolidFill, White);
  123.        r := 0;
  124.        REPEAT
  125.          PieSlice(20, 20, r, r + 10, 16); Inc(r, 30);
  126.        UNTIL r > 360;
  127.      END;
  128.   5: BEGIN
  129.        GrundMuster(r);
  130.        Ellipse(20, 20, 0, 360, 16, 8);
  131.        Ellipse(20, 20, 0, 360, 8, 8);
  132.        SetFillStyle(SolidFill, Black);
  133.        FloodFill( 7, 20, White); FloodFill(33, 20, White);
  134.        FloodFill(20, 14, White); FloodFill(20, 26, White);
  135.        {$IFNDEF VER40}
  136.          FillEllipse(20, 20, 3, 3);
  137.        {$ELSE}
  138.          SetFillStyle(SolidFill, White);
  139.          Circle(20, 20, 3);
  140.          Circle(20, 20, 8);
  141.          SetFillStyle(SolidFill, Black);
  142.        {$ENDIF}
  143.      END;
  144.   6: BEGIN
  145.        GrundMuster(r);
  146.        Circle(20, 20, 10); Circle(12, 20, 8);
  147.        Circle(28, 20,  8); Circle(20, 14, 8);
  148.        Circle(20, 26,  8); SetFillStyle(SolidFill, Black);
  149.        FloodFill(12, 20, White); FloodFill(28, 20, White);
  150.        FloodFill(20, 14, White); FloodFill(20, 26, White);
  151.      END;
  152.   END;
  153. END;
  154.  
  155. (*--------------------------------------------------------*)
  156.  
  157. PROCEDURE SteinGrafiken;
  158. {   zeichnet alle möglichen Steine und speichert sie ab    }
  159. VAR
  160.   farbe, graf: INTEGER;
  161. BEGIN
  162.   SetActivePage(1);
  163.   FOR farbe := 1 TO 6 DO BEGIN
  164.     FOR graf := 1 TO 6 DO BEGIN
  165.       Muster(graf, farbe);
  166.       Size := ImageSize(0, 0, 40, 40);
  167.       GetMem(Stein[(Pred(farbe)) * 6 + graf], Size);
  168.       GetImage(0, 0, 40, 40,
  169.                Stein[(Pred(farbe)) * 6 + graf]^);
  170.       Farben[(Pred(farbe)) * 6 + graf] := farbe;
  171.       Bilder[(Pred(farbe)) * 6 + graf] := graf;
  172.       ClearViewPort;
  173.     END;
  174.   END;
  175.   GetMem(Back, Size);
  176.   SetActivePage(0); Farben[0] := 0; Bilder[0] := 0;
  177. END;
  178.  
  179. (*--------------------------------------------------------*)
  180.  
  181. PROCEDURE HelpMouse(VAR Reg1, Reg2, Reg3, Reg4: INTEGER);
  182. {           Hilfsroutine für die Mausabfrage               }
  183. VAR
  184.   Reg : Registers;
  185. BEGIN
  186.   WITH Reg DO BEGIN
  187.     AX := WORD(Reg1); BX := WORD(Reg2);
  188.     CX := WORD(Reg3); DX := WORD(Reg4);
  189.     Intr(51, Reg);
  190.     Reg1 := INTEGER(AX); Reg2 := INTEGER(BX);
  191.     Reg3 := INTEGER(CX); Reg4 := INTEGER(DX);
  192.   END;
  193. END;
  194.  
  195. (*--------------------------------------------------------*)
  196.  
  197. PROCEDURE MouseCursor;
  198. { stellt den Mauscursor auf dem Bildschirm dar und fragt   }
  199. { die Maustasten ab                                        }
  200. VAR
  201.   t : BOOLEAN;
  202.   ch: CHAR;
  203.  
  204.   PROCEDURE Help;
  205.   {     Hilfedisplay, das mit F1 aufgerufen werden kann    }
  206.   VAR
  207.     lr, i: INTEGER;
  208.     ti   : TextSettingsType;
  209.     ch   : CHAR;
  210.   BEGIN
  211.     IF mode^ = HercMono THEN lr := 59 ELSE lr := 19;
  212.     SetActivePage(0); SetVisualPage(0); GetTextSettings(ti);
  213.     IF NOT DoneFlag THEN BEGIN
  214.       DoneFlag := TRUE; ClearViewPort;
  215.       FOR i := 5 DOWNTO 0 DO BEGIN
  216.         SetColor(Farbe[6 - i]);
  217.         Rectangle(Succ(i), Succ(i),
  218.                   GetMaxX - 2 * i, GetMaxY - 2 * i);
  219.       END;
  220.       SetTextStyle(TriplexFont, HorizDir, 4);
  221.       SetTextJustify(CenterText, CenterText);
  222.       SetColor(Yellow);
  223.       OutTextXY(GetMaxX DIV 2, 24,
  224.                 'Regeln von   O T A S H I');
  225.       SetColor(White);
  226.       SetTextJustify(ti.Horiz, ti.Vert);
  227.       SetTextStyle(DefaultFont, HorizDir, 1);
  228.       OutTextXY(lr,  69, '1. Es dürfen niemals identische S'
  229.                        + 'teine nebeneinander gelegt werden'
  230.                        + '.');
  231.       OutTextXY(lr,  89, '2. Plaziert man einen Stein so au'
  232.                        + 'f dem Spielfeld, daß er an keinen'
  233.                        + ' anderen');
  234.       OutTextXY(lr,  99, '   Stein angrenzt,  hat man nicht'
  235.                        + 's weiter zu beachten.  Es lassen '
  236.                        + 'sich  so');
  237.       OutTextXY(lr, 109, '   auf einfachste Weise 100 Punkt'
  238.                        + 'e erzielen.');
  239.       OutTextXY(lr, 129, '3. Komplizierter wird es,  wenn m'
  240.                        + 'an seinen Stein neben einen ander'
  241.                        + 'en legt.');
  242.       OutTextXY(lr, 139, '   Hierbei  darf  jeweils nur das'
  243.                        + ' Symbol  oder die  Farbe mit dem '
  244.                        + ' anderen');
  245.       OutTextXY(lr, 149, '   Stein übereinstimmen, nicht be'
  246.                        + 'ides.  Für einen solchen Zug gibt'
  247.                        + ' es dann');
  248.       OutTextXY(lr, 159, '   schon 400 Punkte.');
  249.       OutTextXY(lr, 179, '4. Legt man den Stein an  zwei an'
  250.                        + 'dere Steine  an,  so muß  beim  e'
  251.                        + 'inen die');
  252.       OutTextXY(lr, 189, '   Farbe  und beim anderen das Sy'
  253.                        + 'mbol  übereinstimmen,  nicht aber'
  254.                        + ' beides.');
  255.       OutTextXY(lr, 199, '   Dafür gibt es 800 Punkte.');
  256.       OutTextXY(lr, 219, '5. Legt man einen Stein an drei a'
  257.                        + 'ndere Steine an, so gilt folgende'
  258.                        + 's:');
  259.       OutTextXY(lr, 229, '   Eine  gleiche  Farbe und zwei '
  260.                        + 'gleiche Symbole  oder umgekehrt. '
  261.                        + ' Gleiche');
  262.       OutTextXY(lr, 239, '   Steine  dürfen  auch  hierbei '
  263.                        + 'nicht  aneinandergelegt  werden. '
  264.                        + ' Da eine');
  265.       OutTextXY(lr, 249, '   solche Plazierung schon ziemli'
  266.                        + 'ch selten ist, gibt''s gleich 200'
  267.                        + '0 Punkte.');
  268.       OutTextXY(lr, 269, '6. Wem das noch nicht genug ist, '
  269.                        + ' der kann ja versuchen,  seinen'
  270.                        + ' Stein  an');
  271.       OutTextXY(lr, 279, '   vier  andere Steine anzulegen.'
  272.                        + ' Dabei muß zweimal die Farbe und'
  273.                        + '  zweimal');
  274.       OutTextXY(lr, 289, '   das Symbol übereinstimmen. Gle'
  275.                        + 'iche Steine können nicht angelegt'
  276.                        + ' werden.');
  277.       OutTextXY(lr, 299, '   Hierfür gibt es satte 5000 Pun'
  278.                        + 'kte.');
  279.     END;
  280.     REPEAT
  281.       ch := ReadKey; IF ch = Chr(0) THEN ch := ReadKey;
  282.     UNTIL ch <> Chr(0);
  283.     SetTextStyle(ti.Font, ti.Direction, ti.CharSize);
  284.     SetActivePage(1); SetVisualPage(1);
  285.   END; { Help }
  286.  
  287. BEGIN
  288.   t := TRUE;
  289.   GetImage(XPos, YPos, XPos + 40, YPos + 40, Back^);
  290.   REPEAT
  291.     Reg1 := 3; HelpMouse(Reg1, Reg2, Reg3, Reg4);
  292.     IF (XPos <> Reg3) OR (YOld <> Reg4) OR (t = TRUE) THEN
  293.     BEGIN
  294.       PutImage(XPos, YPos, Back^, NormalPut);
  295.       XOld := 0; YOld := Reg4; XPos := Reg3;
  296.       YPos := Round(Reg4 * 1.6);
  297.       IF XPos > 598 THEN BEGIN XPos := 598; XOld := 1; END;
  298.       IF YPos > 309 THEN BEGIN YPos := 309; XOld := 1; END;
  299.       IF XOld = 1 THEN BEGIN
  300.         Reg1 := 4; Reg3 := XPos; Reg4 := YOld;
  301.         HelpMouse(Reg1, Reg2, Reg3, Reg4);
  302.       END;
  303.       GetImage(XPos, YPos, XPos + 40, YPos + 40, Back^);
  304.       PutImage(XPos, YPos, Stein[Stack[Reihe]]^, NormalPut);
  305.     END;
  306.     t := FALSE; a := '';
  307.     IF KeyPressed THEN BEGIN
  308.       ch := ReadKey;
  309.       IF ch = Chr(0) THEN BEGIN
  310.         ch := ReadKey;
  311.         IF (ch = ';') THEN BEGIN
  312.           IF NOT MenuFlag THEN Help ELSE Write(Chr(7));
  313.         END;
  314.       END;
  315.     END;
  316.     IF (Reg2 AND 1 = 1) THEN Taste := 1;
  317.     IF (Reg2 AND 2 = 2) THEN Taste := 2;
  318.     IF (Reg2 AND 3 = 3) THEN Taste := 3;
  319.   UNTIL (Reg2 AND 1 = 1) OR (Reg2 AND 2 = 2);
  320.   PutImage(XPos, YPos, Back^, NormalPut);
  321. END;
  322.  
  323. (*--------------------------------------------------------*)
  324.  
  325. PROCEDURE Titel; {         zeichnet das Titelbild          }
  326. BEGIN
  327.   SetActivePage(0); ClearViewPort;
  328.   SetFillStyle(SolidFill, Black);
  329.   FloodFill(1, 1, Black);
  330.   SetColor(LightBlue);
  331.   Rectangle(0, 20, 639, 329);
  332.   SetTextStyle(GothicFont, HorizDir, 5);
  333.   x := TextWidth('Otashi');
  334.   SetColor(White);
  335.   OutTextXY(Round((640 - x) / 2), 20, 'Otashi');
  336.   FOR y := 1 TO 5 DO BEGIN
  337.     Str(y:1, a);
  338.     OutTextXY( 15, y * 40 + 40, a);
  339.     OutTextXY( 50, y * 40 + 40, Name[y]);
  340.     OutTextXY(480, y * 40 + 40, Punkt[y]);
  341.   END;
  342.   SetTextStyle(TriplexFont, HorizDir, 2);
  343.   x := TextWidth('Linke Maustaste = Spielbeginn');
  344.   OutTextXY(Round((340 - x) / 2), 300,
  345.             'Linke Maustaste = Spielbeginn');
  346.   x := TextWidth('Rechte Maustaste = DOS');
  347.   OutTextXY(340 + Round((320 - x) / 2), 300,
  348.             'Rechte Maustaste = DOS');
  349.   SetColor(LightBlue);
  350.   Line(0, 70, 640, 70); Line(0, 72, 640, 72);
  351.   Line(0, 290, 640, 290); Line(0, 292, 640, 292);
  352.   FOR x := 1 TO 5 DO BEGIN
  353.     PutImage(10 + (Pred(x)) * 50, 25,
  354.              Stein[x + (Pred(x)) * 6]^, NormalPut);
  355.     PutImage(637 - (x) * 50, 25,
  356.              Stein[x + (Pred(x)) * 6]^, NormalPut);
  357.   END;
  358.   SetVisualPage(0);
  359. END;
  360.  
  361. (*--------------------------------------------------------*)
  362.  
  363. PROCEDURE SetzeStein(x, y, z: INTEGER);
  364. BEGIN
  365.   PutImage(20 + (Pred(x)) * 40, 10 + (Pred(y)) * 40,
  366.            Stein[z]^, NormalPut);
  367.   Feld[x, y] := z;
  368. END;
  369.  
  370. (*--------------------------------------------------------*)
  371.  
  372. FUNCTION XPosition: INTEGER;
  373. BEGIN
  374.   XPosition := Round((XPos - 20) / 40) + 1;
  375. END;
  376.  
  377. (*--------------------------------------------------------*)
  378.  
  379. FUNCTION YPosition: INTEGER;
  380. BEGIN
  381.   YPosition := Round((YPos - 10) / 40) + 1;
  382. END;
  383.  
  384. (*--------------------------------------------------------*)
  385.  
  386. PROCEDURE SetzePunkte;
  387. BEGIN
  388.   SetFillStyle(1, 0); Bar(502, 43, 580, 70);
  389.   SetTextStyle(TriplexFont, HorizDir, 1);
  390.   Str(Punkte: 6, a); OutTextXY(500, 40, a);
  391. END;
  392.  
  393. (*--------------------------------------------------------*)
  394.  
  395. PROCEDURE DecStack;
  396. BEGIN
  397.   Bar(590, Reihe * 4, 630, Reihe * 4 + 4);
  398.   Inc(Reihe);
  399.   PutImage(590, Reihe * 4, Stein[Stack[Reihe]]^, NormalPut)
  400. END;
  401.  
  402. (*--------------------------------------------------------*)
  403.  
  404. PROCEDURE Check2;
  405. {    Überprüft, welche Steine neben dem aktuellen liegen   }
  406. VAR
  407.   o, p: INTEGER;
  408. BEGIN
  409.   q := 0; w := 0;
  410.   o := Bilder[Stack[Reihe]]; p := Farben[Stack[Reihe]];
  411.   IF (o = Bilder[Feld[Pred(s),      t ]]) THEN Inc(q);
  412.   IF (o = Bilder[Feld[Succ(s),      t ]]) THEN Inc(q);
  413.   IF (o = Bilder[Feld[     s , Pred(t)]]) THEN Inc(q);
  414.   IF (o = Bilder[Feld[     s , Succ(t)]]) THEN Inc(q);
  415.   IF (p = Farben[Feld[Pred(s),      t ]]) THEN Inc(w);
  416.   IF (p = Farben[Feld[Succ(s),      t ]]) THEN Inc(w);
  417.   IF (p = Farben[Feld[     s , Pred(t)]]) THEN Inc(w);
  418.   IF (p = Farben[Feld[     s , Succ(t)]]) THEN Inc(w);
  419. END;
  420.  
  421. (*--------------------------------------------------------*)
  422.  
  423. PROCEDURE Single;
  424. BEGIN
  425.   Check2;
  426.   IF (q + w = 1) THEN BEGIN
  427.     Inc(Punkte, 400);
  428.     SetzeStein(s, t, z); DecStack; SetzePunkte;
  429.   END;
  430. END;
  431.  
  432. (*--------------------------------------------------------*)
  433.  
  434. PROCEDURE Double;
  435. BEGIN
  436.   Check2;
  437.   IF (q = 1) AND (w = 1) THEN BEGIN
  438.     Inc(Punkte, 800);
  439.     SetzeStein(s, t, z); DecStack; SetzePunkte;
  440.   END;
  441. END;
  442.  
  443. (*--------------------------------------------------------*)
  444.  
  445. PROCEDURE Triple;
  446. BEGIN
  447.   Check2;
  448.   IF ((q = 1) AND (w = 2)) OR
  449.      ((q = 2) AND (w = 1)) THEN BEGIN
  450.     Inc(Punkte, 2000);
  451.     SetzeStein(s, t, z); DecStack; SetzePunkte;
  452.   END;
  453. END;
  454.  
  455. (*--------------------------------------------------------*)
  456.  
  457. PROCEDURE Quadruple;
  458. BEGIN
  459.   Check2;
  460.   IF (q = 2) AND (w = 2) THEN BEGIN
  461.     Inc(Punkte, 5000); SetzeStein(s, t, z);
  462.     DecStack; SetzePunkte;
  463.   END;
  464. END;
  465.  
  466. (*--------------------------------------------------------*)
  467.  
  468. PROCEDURE Check; {          Hauptkontrollroutine           }
  469. BEGIN
  470.   n := 4;
  471.   IF (Feld[Pred(s),      t ] = 0) THEN Dec(n);
  472.   IF (Feld[Succ(s),      t ] = 0) THEN Dec(n);
  473.   IF (Feld[     s , Pred(t)] = 0) THEN Dec(n);
  474.   IF (Feld[     s , Succ(t)] = 0) THEN Dec(n);
  475.   z := Stack[Reihe];
  476.   IF (Feld[     s , Pred(t)] <> z) AND
  477.      (Feld[     s , Succ(t)] <> z) AND
  478.      (Feld[Pred(s),      t ] <> z) AND
  479.      (Feld[Succ(s),      t ] <> z) THEN
  480.     CASE n OF
  481.       0: BEGIN
  482.            Inc(Punkte, 200); SetzePunkte;
  483.            DecStack; SetzeStein(s, t, z);
  484.          END;
  485.       1: Single;
  486.       2: Double;
  487.       3: Triple;
  488.       4: Quadruple;
  489.     END;
  490. END;
  491.  
  492. (*--------------------------------------------------------*)
  493.  
  494. PROCEDURE Spiel; {          Routine für das Spiel          }
  495. VAR
  496.   f1, f2 : INTEGER;
  497. BEGIN
  498.   IF mode^ = HercMono THEN BEGIN
  499.     f1 := 0; f2 := 0;
  500.   END ELSE BEGIN
  501.     f1 := 7; f2 := 8;
  502.   END;
  503.   Punkte := 0;
  504.   FOR x := 0 TO 13 DO FOR y := 0 TO 9 DO Feld[x, y] := 0;
  505.   SetActivePage(1);
  506.   IF mode^ = HercMono THEN BEGIN
  507.     OutTextXY(650, 314, 'Regeln:');
  508.     OutTextXY(650, 329, 'F1-Taste');
  509.   END;
  510.   SetColor(LightBlue);
  511.   Rectangle(0, 0, 639, 339); Rectangle(3, 2, 636, 337);
  512.   FOR x := 1 TO 12 DO
  513.     FOR y := 1 TO 8 DO BEGIN
  514.       IF (x + y) MOD 2 = 0 THEN SetFillStyle(SolidFill, f1)
  515.                            ELSE SetFillStyle(SolidFill, f2);
  516.       Bar((Pred(x)) * 40 + 20, (Pred(y)) * 40 + 10,
  517.           (Pred(x)) * 40 + 60, (Pred(y)) * 40 + 50);
  518.       Rectangle((Pred(x)) * 40 + 20, (Pred(y)) * 40 + 10,
  519.                 (Pred(x)) * 40 + 60, (Pred(y)) * 40 + 50);
  520.     END;
  521.   Line(584, 2, 584, 337); Line(582, 2, 582, 337);
  522.   SetColor(White); SetTextStyle(TriplexFont, HorizDir, 2);
  523.   OutTextXY(505, 20, 'Punkte');
  524.   SetTextStyle(GothicFont, HorizDir, 4);
  525.   SetColor(White);
  526.   a := 'Otashi';
  527.   FOR y := 1 TO 6 DO BEGIN
  528.     x := TextWidth(a[y]);
  529.     OutTextXY(Round(467 + y * 10 + (80 - x) / 2),
  530.                     170 + y * 20, a[y]);
  531.   END;
  532.   SetzePunkte; SetVisualPage(1);
  533.   FOR x := 72 DOWNTO 7 DO
  534.     PutImage(590, x * 4, Stein[Stack[x]]^, NormalPut);
  535.   Reihe := 7;
  536.   FOR x := 1 TO 6 DO BEGIN
  537.     SetzeStein(Pos1[x], Pos2[x], Stack[x]);
  538.     Feld[Pos1[x], Pos2[x]] := Stack[x];
  539.   END;
  540.   REPEAT
  541.     MouseCursor;
  542.     IF (Taste = 1) THEN BEGIN
  543.       s := XPosition; t := YPosition;
  544.       IF (s IN [1..12]) AND
  545.          (t IN [1.. 8]) AND (Feld[s, t] = 0) THEN Check;
  546.     END;
  547.   UNTIL (Taste = 2) OR (Reihe > 72);
  548.   FOR x := 1 TO 5 DO Val(Punkt[x], tp[x], y);
  549.   IF (Punkte >= tp[5]) THEN BEGIN
  550.     Name[6] := '_______________';
  551.     Str(Punkte: 6, Punkt[6]); SetFillStyle(1, 0);
  552.     Bar(170, 150, 470, 200); SetColor(12);
  553.     Rectangle(170, 150, 470, 200);
  554.     Rectangle(173, 152, 467, 198);
  555.     SetColor(15);
  556.     SetTextStyle(DefaultFont, HorizDir, UserCharSize);
  557.     OutTextXY(180, 160, Punkt[6]);
  558.     IF mode^ = HercMono THEN x := 1 ELSE x := 2;
  559.     SetTextStyle(DefaultFont, HorizDir, x);
  560.     OutTextXY(180, 180, Name[6]);
  561.     x := 1;
  562.     REPEAT
  563.       a := UpCase(ReadKey);
  564.       IF a = 'ä' THEN a := 'Ä' ELSE
  565.       IF a = 'ö' THEN a := 'Ö' ELSE
  566.       IF a = 'ü' THEN a := 'Ü';
  567.       IF (a[1] IN [#32..#126, 'Ä', 'Ö', 'Ü', 'ß']) AND
  568.          (x < 16) THEN BEGIN
  569.         Name[6, x] := a[1]; Inc(x);
  570.         Bar(180, 180, 460, 196);
  571.         OutTextXY(180, 180, Name[6]);
  572.       END;
  573.       IF (a = #8) AND (x > 1) THEN BEGIN
  574.         Dec(x); Name[6, x] := '_';
  575.         Bar(180, 180, 460, 196);
  576.         OutTextXY(180, 180, Name[6]);
  577.       END;
  578.       WHILE KeyPressed DO a:= ReadKey;
  579.     UNTIL (a = #27) OR (a = #13);
  580.     FOR x := 1 TO 15 DO
  581.       IF (Name[6, x] = '_') THEN Name[6, x] := #0;
  582.     tp[6] := Punkte;
  583.     FOR x := 1 TO 5 DO
  584.       FOR y := x + 1 TO 6 DO
  585.         IF (tp[y] > tp[x]) THEN BEGIN
  586.           Punkte := tp[y]; tp[y] := tp[x]; tp[x] := Punkte;
  587.           a := Name[x];  Name[x] := Name[y]; Name[y] := a;
  588.         END;
  589.     ReWrite(Safe);
  590.     Write(Safe, FileHeader);
  591.     FOR y := 1 TO 5 DO BEGIN
  592.       Str(tp[y]: 6, b); Str(tp[y]: 6, Punkt[y]);
  593.       a := b + Name[y];
  594.       Write(Safe, a);
  595.     END;
  596.     Close(Safe);
  597.   END;
  598.   IF Reihe > 72 THEN Reihe := 72;
  599.   Titel; Taste := 0; DoneFlag := FALSE;
  600. END;
  601.  
  602. (*--------------------------------------------------------*)
  603.  
  604. PROCEDURE MakeStack;
  605. VAR
  606.   x, y: INTEGER;
  607. BEGIN
  608.   HStack[-2] := 0; HStack[-1] := 0; HStack[0] := 0;
  609.   Randomize;
  610.   FOR x := 1 TO 36 DO HStack[x] := 2;
  611.   y := Round(Random * 5) + 1;
  612.   FOR x := 1 TO 6 DO BEGIN
  613.     Dec(HStack[SStack[y]]); Stack[x] := SStack[y];
  614.     Inc(y);
  615.     IF y > 6 THEN y := 1;
  616.   END;
  617.   FOR x := 7 TO 72 DO BEGIN
  618.     y := Round(Random * 35) + 1;
  619.     IF (HStack[y] = 0) THEN REPEAT
  620.       Inc(y, 3); IF (y > 36) THEN Dec(y, 37);
  621.     UNTIL (HStack[y] <> 0);
  622.     Stack[x] := y; Dec(HStack[y]); Taste := 0;
  623.   END;
  624. END;
  625.  
  626. (*--------------------------------------------------------*)
  627.  
  628. PROCEDURE NeueScoreDatei;
  629. {    Automatisches Anlegen einer neuen Highscore-Tabelle   }
  630. BEGIN
  631.   ReWrite(Safe);
  632.   Write(Safe, FileHeader);
  633.   a := ' 25000toolbox'#0#0#0#0#0#0#0#0; Write(Safe, a);
  634.   a := ' 20000toolbox'#0#0#0#0#0#0#0#0; Write(Safe, a);
  635.   a := ' 15000toolbox'#0#0#0#0#0#0#0#0; Write(Safe, a);
  636.   a := ' 10000toolbox'#0#0#0#0#0#0#0#0; Write(Safe, a);
  637.   a := '  5000toolbox'#0#0#0#0#0#0#0#0; Write(Safe, a);
  638.   Close(Safe);
  639. END;
  640.  
  641. (*--------------------------------------------------------*)
  642.  
  643. PROCEDURE GraphHalt;
  644. {        Fehler bei der Initialisierung der Grafik         }
  645. BEGIN
  646.   Sound(880);
  647.   TextColor(LightGray); WriteLn;
  648.   WriteLn('Dieses Programm benötigt eine EGA-/VGA- ' +
  649.           'oder Hercules-Karte.');
  650.   {$IFNDEF internaldrivers}
  651.     WriteLn('Hinweis: Die Bildschirmtreiber "EGAVGA.BGI"' +
  652.             ' und "HERCMONO.BGI"');
  653.     WriteLn('müssen sich im aktuellen Verzeichnis befinden.');
  654.   {$ENDIF}
  655.   Delay(100);
  656.   WriteLn; TextColor(White);
  657.   Write('Otashi wird abgebrochen!');
  658.   Sound(440);
  659.   TextColor(LightGray); WriteLn; Delay(150);
  660.   NoSound;
  661.   Halt(1);
  662. END;
  663.  
  664. (*--------------------------------------------------------*)
  665.  
  666. BEGIN
  667.   mode := Ptr($40, $49);
  668.   CASE mode^ OF
  669.   {    Festlegen der Farben und Muster der Spielsteine     }
  670.     HercMono:
  671.     BEGIN
  672.       FOR i := 1 TO 6 DO Farbe[i] := 1;
  673.       Fill[1] := SlashFill;     Fill[2] := CloseDotFill;
  674.       Fill[3] := LineFill;      Fill[4] := BkSlashFill;
  675.       Fill[5] := XHatchFill;    Fill[6] := InterleaveFill;
  676.     END;
  677.     BW40, BW80:
  678.     BEGIN
  679.       Farbe[1] := LightBlue;    Fill[1] := SlashFill;
  680.       Farbe[2] := LightGreen;   Fill[2] := CloseDotFill;
  681.       Farbe[3] := Cyan;         Fill[3] := SolidFill;
  682.       Farbe[4] := LightRed;     Fill[4] := BkSlashFill;
  683.       Farbe[5] := LightMagenta; Fill[5] := XHatchFill;
  684.       Farbe[6] := Yellow;       Fill[6] := InterleaveFill;
  685.       MonoMonitor := TRUE;
  686.     END ELSE BEGIN
  687.       {$IFDEF VER40}
  688.         Farbe[1] := Blue;       Farbe[2] := Green;
  689.         Farbe[3] := Cyan;       Farbe[4] := Red;
  690.         Farbe[5] := Magenta;    Farbe[6] := Yellow;
  691.       {$ELSE}
  692.         Farbe[1] := EGABlue;    Farbe[2] := EGAGreen;
  693.         Farbe[3] := EGACyan;    Farbe[4] := EGARed;
  694.         Farbe[5] := EGAMagenta; Farbe[6] := EGAYellow;
  695.       {$ENDIF}
  696.       FOR i := 1 TO 6 DO Fill[i] := SolidFill;
  697.       MonoMonitor := FALSE;
  698.     END;
  699.   END;
  700.   {  Programmnamen für die Scoretabelle aus dem PSP holen: }
  701.   {$IFDEF VER40}
  702.     ScoreFile := 'OTASHI.SCR';
  703.   {$ELSE}
  704.     ScoreFile := ParamStr(0);
  705.     FSplit(ScoreFile, ScoreFileDir, ScoreFileName,
  706.                       ScoreFileExt);
  707.     ScoreFile := Concat(ScoreFileDir,
  708.                         ScoreFileName,
  709.                         '.SCR');
  710.   {$ENDIF}
  711.   IF ScoreFile = '' THEN ScoreFile := 'OTASHI.SCR';
  712.   Assign(Safe, ScoreFile);
  713.   MakeStack; Reihe := 1; Reg1 := 0;
  714.   HelpMouse(Reg1, Reg2, Reg3, Reg4);
  715.   IF Reg1 = -1 THEN BEGIN
  716.     x := 0; y := 0;
  717.     {$IFNDEF VER40}
  718.       FindFirst(ScoreFile, AnyFile, sr);
  719.       IF DosError = 18 THEN NeueScoreDatei;
  720.       Reset(Safe);
  721.     {$ELSE}
  722.       Reset(Safe);
  723.       IF IoResult <> 0 THEN BEGIN
  724.         NeueScoreDatei;
  725.         Reset(Safe);
  726.       END;
  727.     {$ENDIF}
  728.     Seek(Safe, 1);
  729.     REPEAT
  730.       { Länge der Scoretabelle ist fehlerhaft --> nochmal: }
  731.       IF Eof(Safe) THEN BEGIN
  732.         Close(Safe); NeueScoreDatei;
  733.         Reset(Safe); Seek(Safe, 1);
  734.         y := 0;
  735.       END;
  736.       INC(y);
  737.       Read(Safe, a);
  738.       Punkt[y] := Copy(a, 1, 6);
  739.       Name[y]  := Copy(a, 7, 15);
  740.     UNTIL y > 4;
  741.     DetectGraph(GraphDriver, GraphMode);
  742.     IF mode^ = HercMono THEN BEGIN
  743.       GraphDriver := mode^;
  744.       GraphMode   := HercMonoHi;
  745.     END ELSE BEGIN
  746.       IF NOT (GraphDriver IN [EGA, VGA]) THEN GraphHalt;
  747.       GraphDriver := EGA;
  748.       GraphMode   := EGAHi;
  749.     END;
  750.     {$IFDEF internaldrivers}
  751.       i := RegisterBGIDriver(@EGAVGADriverProc);
  752.       j := RegisterBGIDriver(@HercDriverProc);
  753.       IF (i < 0) OR (j < 0) THEN BEGIN
  754.         TextColor(LightGray);
  755.         WriteLn('Fehler bei der Installation der Grafik.');
  756.         TextColor(White); WriteLn('Otashi wird abgebrochen.');
  757.         TextColor(LightGray); Halt(2);
  758.       END;
  759.      {$ENDIF}
  760.      {$IFDEF internalfonts}
  761.       {$IFDEF VER60}
  762.         RegisterBGIFont(@TriplexFontProc);
  763.         RegisterBGIFont(@GothicFontProc);
  764.       {$ELSE}
  765.         i := RegisterBGIFont(@TriplexFontProc);
  766.         i := RegisterBGIFont(@GothicFontProc);
  767.       {$ENDIF}
  768.     {$ENDIF}
  769.     InitGraph(GraphDriver, GraphMode, GetEnv('BGIPATH'));
  770.     IF GraphResult < 0 THEN GraphHalt;
  771.     SetColor(LightBlue);
  772.     Rectangle(0, 20, GetMaxX - 1, GetMaxY - 20);
  773.     SetTextJustify(CenterText, CenterText);
  774.     SetColor(Yellow);
  775.     SetTextStyle(GothicFont, HorizDir, 7);
  776.     OutTextXY(GetMaxX DIV 2, GetMaxY DIV 2 - 110,
  777.               'O t a s h i');
  778.     SetTextStyle(TriplexFont, HorizDir, 2);
  779.     OutTextXY(GetMaxX - 75, GetMaxY DIV 2 - 100, version);
  780.     SetTextStyle(GothicFont, HorizDir, 5);
  781.     OutTextXY(GetMaxX DIV 2, GetMaxY DIV 2,
  782.               '(c) 1991 V. Stegmann & toolbox');
  783.     SetColor(LightRed);
  784.     SetTextStyle(TriplexFont, HorizDir, 3);
  785.     OutTextXY(GetMaxX DIV 2, GetMaxY DIV 2 + 80,
  786.               'Spielsteine werden aufgebaut');
  787.     OutTextXY(GetMaxX DIV 2, GetMaxY DIV 2 + 110,
  788.               'Bitte warten . . .');
  789.     SetTextJustify(LeftText, TopText);
  790.     SteinGrafiken; MenuFlag := TRUE; Titel;
  791.     REPEAT
  792.       MouseCursor;
  793.       IF (Reg2 AND 1 = 1) THEN BEGIN
  794.         Punkte := 0; Size := ImageSize(0, 300, 50, 300);
  795.         GetMem(Back2, Size);
  796.         GetImage(170, 150, 470, 200, Back2^);
  797.         SetFillStyle(SolidFill, Black);
  798.         Bar(170, 150, 470, 200);
  799.         SetColor(LightRed); Rectangle(170, 150, 470, 200);
  800.         Rectangle(173, 152, 467, 198); SetColor(White);
  801.         SetTextStyle(DefaultFont, HorizDir, UserCharSize);
  802.         OutTextXY(180, 160,
  803.                     'Wollen Sie die Steine neu mischen ?');
  804.         OutTextXY(220, 175, 'Linke Maustaste  =  Ja');
  805.         OutTextXY(220, 187, 'Rechte Maustaste =  Nein');
  806.         Delay(350); MouseCursor; Delay(350);
  807.         IF Taste = 1 THEN MakeStack; Taste := 0;
  808.         PutImage(170, 150, Back2^, NormalPut);
  809.         MenuFlag := FALSE; Spiel; MenuFlag := TRUE;
  810.       END;
  811.     UNTIL Taste = 2;
  812.     CloseGraph; TextMode(LastMode);
  813.   END ELSE BEGIN
  814.     Write('Maustreiber fehlt !'); TextColor(White);
  815.     Write('Otashi wird abgebrochen.');
  816.     TextColor(LightGray); WriteLn;
  817.   END;
  818. END.
  819.  
  820. (*========================================================*)
  821. (*                 Ende von Otashi.Pas                    *)
  822.