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