home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1991 / 05 / txtris / txtris.cbl next >
Encoding:
Text File  |  1991-03-27  |  31.1 KB  |  897 lines
  1.        Identification Division .
  2.        Program-Id . TXTRIS .
  3.        Author. (c) TOOLBOX & H.-G. Schima .
  4.           Sollte eigentlich auf jeden COBOL-Compiler
  5.           umsetzbar sein.
  6.        Data Division .
  7.        Working-Storage Section .
  8.       *Tabellen
  9.        01 c-screenzeile occurs 24 times .
  10.       05 c-screen                pic x occurs 38 times .
  11.        01 varteile .
  12.       05 teile   occurs 7 times .
  13.          10 teilev occurs 4 times .
  14.         15 teilreihe occurs 4 times .
  15.            20 teilelement        pic x occurs 8 times .
  16.       *Immer zuerst einen Bereich definieren, und mit Werten vorbelegen
  17.       *Anschliessen die Tabelle ueber diesen Bereich legen.
  18.        01 d-teily1-offset .
  19.       05  filler1                pic 9 value 2 .
  20.       05  filler2                pic 9 value 2 .
  21.       05  filler3                pic 9 value 1 .
  22.       05  filler4                pic 9 value 1 .
  23.       05  filler5                pic 9 value 1 .
  24.       05  filler6                pic 9 value 1 .
  25.       05  filler7                pic 9 value 2 .
  26.        01 teily1-offset redefines d-teily1-offset
  27.                         pic 9 occurs 7 times .
  28.       *Alter Cobol Trick, Tabellen lassen sich nicht mit Werten direkt
  29.       *vorbelegen
  30.        01 d-teile-zeichen .
  31.       05  filler8                pic x(7) value "X@$#[]*" .
  32.        01 teile-zeichen redefines d-teile-zeichen
  33.                         pic x(1) occurs 7 times .
  34.       *Alter Cobol Trick, Tabellen lassen sich nicht mit Werten direkt
  35.       *vorbelegen
  36.        01 teil .
  37.       05 filler occurs 4 .
  38.          10 ateilelement            pic x occurs 8 times .
  39.        01 teil2 .
  40.       05 filler occurs 4 .
  41.          10 ateil2element            pic x occurs 8 times .
  42.        01 tastentyp                pic x(1) .
  43.       *Konstanten
  44.        01 empty                 pic x(1) value space .
  45.        01 reihen-pro-level            pic 99 value 10 .
  46.        01 min-verzoegerung            pic 9 value 4 .
  47.        01 Step-verzoegerung            pic 9 value 7 .
  48.        01 info-x                pic 99 value 64 .
  49.        01 emptyline                pic x(38) value
  50.       "||                      ||" .
  51.        01 anz-teile                pic 9 value 7 .
  52.        01 teilx1-start                pic 99 comp value 16 .
  53.        01 teily1-start                pic 99 comp value 1 .
  54.        01 maxx                    pic 99 comp value 38 .
  55.        01 maxy                    pic 99 comp value 23 .
  56.       *Variablen zum Programmablauf
  57.        01 pc-faktor                pic 9(5) comp value 0 .
  58.        01 rand-seed                pic 9(3)v9(15) comp .
  59.        01 zufall                pic 9(3)v9(15) comp .
  60.        01 zufallszahl                pic 99 comp .
  61.        01 uebernaechstes            pic 99 comp .
  62.        01 teilnr                pic 99 comp .
  63.        01 teilphase                pic 9 .
  64.        01 teilphase2                pic 9 .
  65.        01 teil-zeichen                pic x .
  66.        01 teilx1                pic 9(4) comp .
  67.        01 teily1                pic 9(4) comp .
  68.        01 xx                    pic 9(4) comp .
  69.        01 yy                    pic 9(4) comp .
  70.        01 nn                    pic 9(4) comp .
  71.        01 xcoord                pic 99 comp .
  72.        01 ycoord                pic 99 comp .
  73.        01 taste-zaehler             pic 9(9) comp .
  74.        01 game-over                pic 9 value 0 .
  75.        01 senken-ok                pic 9 value 0 .
  76.        01 again                 pic 9 value 1 .
  77.        01 move-ok                pic 9 value 1 .
  78.        01 element-gefunden            pic 9 value 1 .
  79.        01 line-full                pic 9 value 0 .
  80.        01 rotieren-ok                pic 9 value 1 .
  81.        01 taste                 pic x value low-value .
  82.        01 zeichen                pic xx .
  83.        01 score                 pic 9(9) comp value 0.
  84.        01 level                 pic 9 .
  85.        01 levelneu                pic 9 .
  86.        01 zeilen-zaehler            pic 9(4) comp .
  87.        01 level-zaehler             pic 9(4) comp .
  88.        01 nochmal-taste             pic x .
  89.        01 waitkey                pic 9(2) comp-x .
  90.        01 links                 pic x value "1" .
  91.        01 rechts                pic x value "2" .
  92.        01 rotieren                pic x value "3" .
  93.        01 fallen                pic x value "4" .
  94.        01 abbruch                pic x value "9" .
  95.        01 leer                    pic x value low-values .
  96.        01 getastet                pic x .
  97.        01 zwischenwert                pic v9(18) .
  98.        01 anzeigezeile                pic 99 .
  99.        01 anzeigeposition            pic 99 .
  100.        01 anzeigeteil                pic X .
  101.        01 positionierung .
  102.       05 row-number             pic 9(2) comp-x .
  103.       05 col-number             pic 9(2) comp-x .
  104.        01 cls-character             pic x value " " .
  105.        01 cls-attribute             pic x value X"07" .
  106.        01 dummywert1                pic 9(9) comp .
  107.        01 dummywert2                pic 9(9) comp .
  108.        01 pruefzeile                pic 9(2) comp .
  109.        01 maxpruefzeile             pic 9(2) value 23 .
  110.        01 zeit .
  111.       05 stunde                pic 99 .
  112.       05 minute                pic 99 .
  113.       05 sekunde                pic 99 .
  114.       05 s100                pic 99 .
  115.       *Ersatz fuer Logische Variablen
  116.        01 JA                    pic 9 value 1 .
  117.        01 NEIN                    pic 9 value 0 .
  118.       *
  119.       ******************************************************************
  120.       *Das Programm beginnt immer mit der Procedure Division. Inner-
  121.       *halb dieser Division wird mit dem ersten Befehl begonnen. Die
  122.       *Steuerung des Programms wurde aus dem Pascal Programm von hinten
  123.       *nach vorne verlegt. Ein Chauffeur sitzt schliesslich auch vorne
  124.       *im Auto und hat vor sich nur den Motor (die Variablen) .
  125.       *
  126.        PROCEDURE DIVISION .
  127.        Action Section .
  128.        Haupt .
  129.        perform initialisieren-fallteile .
  130.        perform ask-defaults .
  131.        perform cursoroff .
  132.        perform starte-zufall .
  133.        perform with test after until again = nein
  134.           perform init-spiel
  135.           perform spiel
  136.           perform end-abfrage
  137.        end-perform
  138.        perform ende .
  139.        cursoroff .
  140.       *In diesem Paragraphen wird der sichtbare Cursor ausgeschaltet
  141.       *da das aber nicht bei allen Systemen geht, wird auch hier
  142.       *dieser Paragraph auf DUMMY gesetzt also hat er keine Funktion
  143.       *Sie können diesen Paragraphen aber so erweitern, das der Cursor
  144.       *ausgeschaltet wird. Dies sollte dann aber in einem Unterprogramm
  145.       *geschehen
  146.        EXIT .
  147.        cursoron .
  148.       *In diesem Paragraphen wird der sichtbare Cursor angeschaltet
  149.       *da das aber nicht bei allen Systemen geht, wird auch hier
  150.       *dieser Paragraph auf DUMMY gesetzt also hat er keine Funktion
  151.       *Sie können diesen Paragraphen aber so erweitern, das der Cursor
  152.       *angeschaltet wird. Dies sollte dann aber in einem Unterprogramm
  153.       *geschehen
  154.        EXIT .
  155.        hole-taste .
  156.       *Da COBOL Standardmaessig keine INKEY-Funktion besitzt
  157.       *wird hier eine Routine genutzt, die mit dem COBOL-Compiler
  158.       *geliefert wurde. Diese Routine setzt die die Variable waitkey
  159.       *auf 0 wenn keine Taste gedrueckt wurde, andernfalls auf 1
  160.        move 0 to waitkey .
  161.        call "CBL_GET_KBD_STATUS" using waitkey .
  162.        if waitkey = 1
  163.           call "CBL_READ_KBD_CHAR" using getastet
  164.           evaluate getastet
  165.           when "7"
  166.          move links to taste
  167.           when "9"
  168.          move rechts to taste
  169.           when "8"
  170.          move rotieren to taste
  171.           when " "
  172.          move fallen to taste
  173.           when X"1B"
  174.          move abbruch to taste
  175.           when any
  176.          move leer to taste
  177.           end-evaluate
  178.        else
  179.           move leer to taste .
  180.        clear-screen .
  181.       *Loeschen des ganzen Bildschirm
  182.       *Fuer MS-COBOL 4.0
  183.       *       call "CBL_CLEAR_SCR" using cls-character
  184.       *                      cls-attribute .
  185.       *Fuer andere Cobol-Compiler. High-Value deshalb weil
  186.       *der MS-COBOL-Compiler leider Probleme mit dem SPACE hat
  187.       *Dies ist zwar ein bischen langwierig, aber dafuer um so
  188.       *sicherer. Übrigens: High-Value ist Hex "FF" manche Compiler
  189.       *deuten High-Value als Hex "7F" dafür schlagen Sie bitte in
  190.       *den Handbüchern des Compilers nach.
  191.        perform varying yy from 1 by 1 until yy > 24
  192.           perform varying xx from 1 by 1 until xx > 80
  193.          display high-values at line yy
  194.                     column xx
  195.          end-perform
  196.       end-perform .
  197.        Zeichne-spielfeld .
  198.       *Aufbau des Spielfelds. Wenn man in diesem Programm mit Farben
  199.       *arbeiten moechte kann man jede Display-Anweisung auch noch mit
  200.       *Farbopitionen ausstatten. Als Beispiel stehen hier die Kommentar-
  201.       *zeilen
  202.       *
  203.        perform clear-screen .
  204.       *
  205.       *Der Bereich wo die Steine fallen
  206.       *Eigentlich fallen die Steine in einer Tabelle
  207.       *
  208.        perform varying xx from 1 by 1 until xx > 23
  209.           move emptyline to c-screenzeile (xx)
  210.        end-perform
  211.        move "++==================================++"
  212.           to c-screenzeile (24)
  213.        perform varying xx from 1 by 1 until xx > 23
  214.           display emptyline at line xx column 1
  215.       *           with foreground-color 7
  216.       *           background-color is 0
  217.        end-perform
  218.       *
  219.       *Das Spielfeld ist jetzt in der linken Schirmhälfte aufgebaut.
  220.       *Jetzt wird auf der rechten Schirmhälfte eine Maske aufgebaut,
  221.       *in welcher der Level, die vollen Reihen und die Punktzahl an-
  222.       *gezeigt werden.
  223.       *
  224.        display
  225.            "++==================================++"
  226.            at line 24 column 1
  227.       *           with foreground-color 0
  228.       *           background-color is 2
  229.        display "TTTTT X   X   TTTTT RRRR   III   SSSS"
  230.            at line 1 column 42
  231.       *           with foreground-color 0
  232.       *           background-color is 2
  233.        display
  234.            "  T    X X        T    R   R    I   S    "
  235.            at line 2 column 42
  236.       *           with foreground-color 0
  237.       *           background-color is 2
  238.        display
  239.            "  T     X  ___  T    RRRR    I    SSS "
  240.            at line 3 column 42
  241.       *           with foreground-color 0
  242.       *           background-color is 2
  243.        display
  244.            "  T    X X        T    R R    I    S"
  245.            at line 4 column 42
  246.       *           with foreground-color 0
  247.       *           background-color is 2
  248.        display
  249.            "  T   X   X     T    R  R    I   SSSS "
  250.            at line 5 column 42
  251.       *           with foreground-color 0
  252.       *           background-color is 2
  253.        display
  254.            "-------------------------------------"
  255.            at line 6 column 42
  256.       *           with foreground-color 0
  257.       *           background-color is 2
  258.        display
  259.            "| Das 'unmoegliche' Spiel in COBOL  |"
  260.            at line 7 column 42
  261.       *           with foreground-color 0
  262.       *           background-color is 2
  263.        display
  264.            "| (C) 1991 Toolbox & H.-G. Schima   |"
  265.            at line 8 column 42
  266.       *           with foreground-color 0
  267.       *           background-color is 2
  268.        display
  269.            "+-----------------------------------+"
  270.            at line 9 column 42
  271.       *           with foreground-color 0
  272.       *           background-color is 2
  273.        display
  274.            "| Punkte         :                  |"
  275.            at line 10 column 42
  276.       *           with foreground-color 0
  277.       *           background-color is 2
  278.        display
  279.            "+-----------------------------------+"
  280.            at line 11 column 42
  281.       *           with foreground-color 0
  282.       *           background-color is 2
  283.        display
  284.            "| Level          :                  |"
  285.            at line 12 column 42
  286.       *           with foreground-color 0
  287.       *           background-color is 2
  288.        display
  289.            "+-----------------------------------+"
  290.            at line 13 column 42
  291.       *           with foreground-color 0
  292.       *           background-color is 2
  293.        display
  294.            "| Reihen         :                  |"
  295.            at line 14 column 42
  296.       *           with foreground-color 0
  297.       *           background-color is 2
  298.        display
  299.            "+-----------------------------------+"
  300.            at line 15 column 42
  301.       *           with foreground-color 0
  302.       *           background-color is 2
  303.        display
  304.            "| Naechstes Teil :                  |"
  305.            at line 16 column 42
  306.       *           with foreground-color 0
  307.       *           background-color is 2
  308.        display
  309.            "|                                   |"
  310.            at line 17 column 42
  311.       *           with foreground-color 0
  312.       *           background-color is 2
  313.        display
  314.            "|                                   |"
  315.            at line 18 column 42
  316.       *           with foreground-color 0
  317.       *           background-color is 2
  318.        display
  319.            "|                                   |"
  320.            at line 19 column 42
  321.       *           with foreground-color 0
  322.       *           background-color is 2
  323.        display
  324.            "+-----------------------------------+"
  325.            at line 20 column 42
  326.       *           with foreground-color 0
  327.       *           background-color is 2
  328.        display
  329.            "| B E D I E N U N G :               |"
  330.            at line 21 column 42
  331.       *           with foreground-color 0
  332.       *           background-color is 2
  333.        display
  334.            "| <7>   Links   <9> Rechts          |"
  335.            at line 22 column 42
  336.       *           with foreground-color 0
  337.       *           background-color is 2
  338.        display
  339.            "| <8>   Drehen  <SPACE> Drop        |"
  340.            at line 23 column 42
  341.       *           with foreground-color 0
  342.       *           background-color is 2
  343.        display
  344.            "+-----------------------------------+"
  345.            at line 24 column 42 .
  346.       *           with foreground-color 0
  347.       *           background-color is 2 .
  348.        hole-zufall .
  349.       *Im COBOL-Standard gibt es keine Zufallszahlen, da dies eine
  350.       *kaufmännische Sprache ist, und ein Kaufmann nichts zufälliges
  351.       *braucht.
  352.        perform starte-zufall .
  353.        compute zwischenwert = rand-seed * 997
  354.        compute zufallszahl rounded = (zwischenwert * anz-teile) .
  355.       *Um sicher zu sein, das die Zufallszahl zwischen 1 und 7 liegt
  356.       *wird hier noch eine Überprüfung angehängt.
  357.        if zufallszahl < 1
  358.           move 1 to zufallszahl
  359.        end-if .
  360.        if zufallszahl > 7
  361.           move 7 to zufallszahl
  362.        end-if .
  363.        starte-zufall .
  364.        accept zeit from time .
  365.        compute rand-seed = 1 / (s100 + 13) .
  366.        init-spiel .
  367.        perform hole-zufall .
  368.        move zufallszahl to uebernaechstes
  369.       *Zu Beginn des Spiels hat man natürlich noch keine Punkte usw.
  370.        move 0 to score .
  371.        move 0 to zeilen-zaehler
  372.        compute level-zaehler =
  373.           (Min-verzoegerung + (9 - level) * step-verzoegerung)
  374.           * pc-faktor .
  375.        perform zeichne-spielfeld .
  376.        display level at line 12 column info-x .
  377.        ziehe-teil .
  378.       *Aus der großen Kiste wird der Stein gezogen, der als nächster
  379.       *fallen soll. Dieser Stein wird auch sofort angezeigt.
  380.        perform hole-zufall
  381.        move uebernaechstes to teilnr
  382.        move zufallszahl to uebernaechstes
  383.        move 1 to yy
  384.        perform until yy > 4
  385.           move 1 to xx
  386.           perform until xx > 8
  387.          add 15, yy giving anzeigezeile
  388.          add 64, xx giving anzeigeposition
  389.          if teilelement(uebernaechstes,1,yy,xx) not = empty
  390.             move teilelement(uebernaechstes,1,yy,xx)
  391.                to anzeigeteil
  392.          else
  393.             move space to anzeigeteil
  394.          end-if
  395.          display anzeigeteil at line anzeigezeile
  396.                        column anzeigeposition
  397.          add 1 to xx
  398.           end-perform
  399.           add 1 to yy
  400.        end-perform .
  401.       *Fest steht immer, daß das Teil in der 1. Form auf dem Spielfeld
  402.       *erscheinen soll.
  403.        move 1 to teilphase
  404.        move teilev(teilnr, teilphase) to teil .
  405.        move teilx1-start to teilx1 .
  406.       *Auf welcher Zeile des Spielfelds der Stein erscheinen soll, wird
  407.       *errechnet. Beim Berechnen der Zeile gibt es zwei Wege. Es sind
  408.       *beide Rechenwege beschrieben. Einer allerdings nur als Kommentar.
  409.        compute teily1 =
  410.            teily1-start - (teily1-offset (teilnr) * -1) .
  411.       *       move teily1-start to teily1 .
  412.       *       subtract teily1-offset (teilnr) from teily1 .
  413.        move teile-zeichen(teilnr) to teil-zeichen .
  414.       *Überprüfung, ob an der Stelle, wo der Stein erscheinen soll schon
  415.       *etwas ist. Sollte das der Fall sein, wird das Spiel beendet.
  416.        move 1 to yy
  417.        perform until yy > 4
  418.           move 1 to xx
  419.           perform until xx > 8
  420.              or game-over = ja
  421.          if ateilelement (yy,xx) not = " "
  422.             if (teily1 + yy) > 1
  423.                add teily1, yy, -1 giving dummywert1
  424.                add teilx1, xx giving dummywert2
  425.                if c-screen (dummywert1,dummywert2) not = " "
  426.               move ja to game-over
  427.                end-if
  428.             end-if
  429.          end-if
  430.          add 2 to xx
  431.           end-perform
  432.           add 1 to yy
  433.        end-perform .
  434.        zeichne-element .
  435.       *Jedes Element des Steins ist immer 2 Zeichen lang. Die Position
  436.       *des Elements auf dem Spielfeld wird immer errechnet
  437.        add teilx1, xx giving xcoord
  438.        add teily1, yy, -1 giving ycoord
  439.        if ycoord > 0
  440.           display zeichen at line ycoord
  441.                  column xcoord
  442.        end-if .
  443.        zeichne-teil .
  444.       *Jedes Teil wird Zeilenweise in seine Elemente zerlegt, die immer
  445.       *2 Zeichen lang sind.
  446.        move 1 to yy .
  447.        perform until yy > 4
  448.           move 1 to xx
  449.           perform until xx > 8
  450.          if ateilelement (yy, xx) not = " "
  451.       *Für neue COBOL-Freunde  in Klammern wird die Position genannt
  452.       *auf die das teil-zeichen gesetzt wird und die Länge
  453.       *Format (POSITION:LÄNGE)
  454.             move teil-zeichen to zeichen (1:1)
  455.             move teil-zeichen to zeichen (2:1)
  456.             perform zeichne-element
  457.          end-if
  458.          add 2 to xx
  459.           end-perform
  460.           add 1 to yy
  461.        end-perform .
  462.        loesche-teil .
  463.       *Wenn das Teil gedreht oder verschoben wurde, muss es erst einmal
  464.       *geloescht werden, bevor man es wieder anzeigen kann. Dies ver-
  465.       *hindert ein Chaos auf dem Bildschirm. Auch hier wurde wieder mit
  466.       *High-Values gearbeitet.
  467.        move 1 to yy .
  468.        perform until yy > 4
  469.           move 1 to xx
  470.           perform until xx > 8
  471.          if ateilelement (yy, xx) not = " "
  472.             move high-values to zeichen
  473.             perform zeichne-element
  474.          end-if
  475.          add 2 to xx
  476.           end-perform
  477.           add 1 to yy
  478.        end-perform .
  479.        senke-teil .
  480.       *Beim Senken eines Teils, wird immer erst überprüft, ob überhaupt
  481.       *gesenkt werden kann
  482.        move ja to senken-ok .
  483.        move 1 to xx .
  484.        perform with test after until xx > 8
  485.           move 4 to yy
  486.           perform until yy < 1
  487.          if ateilelement (yy,xx) not = " "
  488.             add teily1, yy giving dummywert1
  489.             add teilx1, xx giving dummywert2
  490.             if c-screen (dummywert1,dummywert2) not = " "
  491.                move nein to senken-ok
  492.             end-if
  493.          end-if
  494.          subtract 1 from yy
  495.           end-perform
  496.           add 1 to xx
  497.        end-perform .
  498.        if senken-ok = ja
  499.       *Unter dem Teil ist alles in Ordnung und es wird abgesenkt. Und
  500.       *zwar in der Darstellung wie bisher
  501.           perform loesche-teil
  502.           add 1 to teily1
  503.           perform zeichne-teil
  504.        else
  505.       *Irgend etwas ist unter dem Teil und jetzt geht's los
  506.       * 1. Das Teil wird noch einmal angezeigt auf der bisherigen
  507.       *    Position
  508.       * 2. Dafür, daß das Teil unten angekommen ist, gibt es Punkte
  509.       * 3. Wenn die Zeile in der das Teil endet voll ist gibt es
  510.       *    eine Punkt mehr bei den Zeilen (Länderpunkt (Tutti-Frutti))
  511.       * 4. Die volle Zeile wird geloescht, und der Bildschirm korrigiert
  512.       * 5. Ein neuer Stein wird aus dem Hut gezogen
  513.       *
  514.       * 1.
  515.           move 1 to xx
  516.           perform with test after until xx > 8
  517.          move 1 to yy
  518.          perform until yy > 4
  519.             if ateilelement (yy,xx) not = " "
  520.                add teily1, yy, -1 giving dummywert1
  521.                add teilx1, xx giving dummywert2
  522.                move teil-zeichen
  523.              to c-screen (dummywert1,dummywert2)
  524.                add 1 to dummywert2
  525.                move teil-zeichen
  526.              to c-screen (dummywert1,dummywert2)
  527.             end-if
  528.             add 1 to yy
  529.          end-perform
  530.          add 2 to xx
  531.           end-perform
  532.       *2.
  533.           add level to score
  534.           display score at line 10 column info-x
  535.           add maxy, 1 giving yy
  536.           perform until yy < 2
  537.          subtract 1 from yy
  538.          move ja to line-full
  539.          move 3 to xx
  540.          perform until xx > (maxx - 2)
  541.             if c-screen (yy,xx) = " "
  542.                move nein to line-full
  543.             end-if
  544.             add 1 to xx
  545.          end-perform
  546.          if line-full = ja
  547.       *3.
  548.       *Wer moechte kann an dieser Stelle einen Gong einbauen
  549.       *               display X"07"
  550.       *Wenn allerdings der Chef kommt macht Ihn dieses Gepiepse
  551.       *sicherlich stutzig.
  552.             add 1 to zeilen-zaehler
  553.             display zeilen-zaehler at line 14
  554.                       column info-x
  555.             compute levelneu =
  556.                 zeilen-zaehler / reihen-pro-level + 1
  557.             if levelneu > 9
  558.                move 9 to levelneu
  559.             end-if
  560.             if levelneu > level
  561.                move levelneu to level
  562.                compute level-zaehler =
  563.                (Min-verzoegerung + (9 - level)
  564.                 * step-verzoegerung) * pc-faktor
  565.                display level at line 12 column info-x
  566.             end-if
  567.             add yy, 1 giving xx
  568.       *4.
  569.             perform until xx < 3
  570.                subtract 1 from xx
  571.                move c-screenzeile (xx - 1)
  572.                  to c-screenzeile (xx)
  573.             end-perform
  574.             move emptyline to c-screenzeile (1)
  575.             move 1 to xcoord
  576.             move 0 to ycoord
  577.             perform until ycoord > yy
  578.                add 1 to ycoord
  579.                move 0 to nn
  580.                perform until nn > 37
  581.               add 1 to nn
  582.               move nn to xcoord
  583.               move c-screen (ycoord,nn) to anzeigeteil
  584.               display anzeigeteil at line ycoord
  585.                            column xcoord
  586.                end-perform
  587.             end-perform
  588.          end-if
  589.          move nein to line-full
  590.           end-perform
  591.       *5.
  592.           perform ziehe-teil
  593.        end-if .
  594.        drop-teil .
  595.       *Wenn man Mutig genug war die Leertaste zu drücken, wird der Stein
  596.       *auf der Stelle fallengelassen. (Wie beim Feierabend der Kuli)
  597.        perform with test after until senken-ok = nein
  598.           perform senke-teil
  599.        end-perform .
  600.       *Die Punktzahl muss man dann auch dementsprechend erhöhen.
  601.       *Denn Risiko muß sich lohnen
  602.        compute score = score + level * (Maxy - Teily1)
  603.        display score at line 10 column info-x .
  604.        move-teil-links .
  605.       *Es wird links von dem Teil ueberprueft, ob noch Platz ist
  606.       *Wenn ja, wird geschoben und angezeigt
  607.        move ja to move-ok .
  608.        perform varying yy from 1 by 1 until yy > 4
  609.           move nein to element-gefunden
  610.           move 1 to xx
  611.           perform until xx > 8
  612.          or element-gefunden = ja
  613.          if ateilelement (yy, xx) not = " "
  614.             move ja to element-gefunden
  615.             add teily1, yy, -1 giving dummywert1
  616.             add teilx1, xx, -1 giving dummywert2
  617.             if c-screen (dummywert1,dummywert2) not = " "
  618.                move nein to move-ok
  619.             end-if
  620.          end-if
  621.          add 2 to xx
  622.           end-perform
  623.        end-perform .
  624.        if move-ok = ja
  625.           perform loesche-teil
  626.           subtract 2 from teilx1
  627.           perform zeichne-teil
  628.        end-if .
  629.        move-teil-rechts .
  630.       *Wie bei Links nur halt auf der rechten Seite.
  631.        move ja to move-ok .
  632.        perform varying yy from 1 by 1 until yy > 4
  633.           move nein to element-gefunden
  634.           move 8 to xx
  635.           perform until xx < 1
  636.             or element-gefunden = ja
  637.          if ateilelement (yy,xx) not = " "
  638.             move ja to element-gefunden
  639.             add teily1, yy, -1 giving dummywert1
  640.             add teilx1, xx, 1 giving dummywert2
  641.             if c-screen (dummywert1,dummywert2) not = " "
  642.                move nein to move-ok
  643.             end-if
  644.          end-if
  645.          subtract 2 from xx
  646.           end-perform
  647.        end-perform
  648.        if move-ok = ja
  649.           perform loesche-teil
  650.           add 2 to teilx1
  651.           perform zeichne-teil
  652.        end-if .
  653.        rotiere-teil .
  654.       *Beim Rotieren wird Rechts, Links und Untendrunter geguckt, ob
  655.       *noch Platz ist.
  656.        move ja to rotieren-ok
  657.        add teilphase, 1 giving teilphase2
  658.        if teilphase2 > 4
  659.           move 1 to teilphase2
  660.        end-if
  661.        move teilev (teilnr, teilphase2) to teil2
  662.        perform varying yy from 1 by 1 until yy > 4
  663.           move 1 to xx
  664.           perform until xx > 8
  665.              or rotieren-ok = nein
  666.          if ateil2element (yy,xx) not = " "
  667.             if (teily1 + yy - 1) < 1
  668.             move nein to rotieren-ok
  669.             end-if
  670.             if rotieren-ok = ja
  671.                add teily1, yy, -1 giving dummywert1
  672.                add teilx1, xx giving dummywert2
  673.                if c-screen (dummywert1,dummywert2) not = " "
  674.                move nein to rotieren-ok
  675.                end-if
  676.             end-if
  677.          end-if
  678.          add 2 to xx
  679.           end-perform
  680.        end-perform
  681.        if rotieren-ok = ja
  682.           perform loesche-teil
  683.           move teil2 to teil
  684.           move teilphase2 to teilphase
  685.           perform zeichne-teil
  686.        end-if .
  687.        ende .
  688.       perform cursoron .
  689.       perform clear-screen .
  690.       stop run .
  691.        spiel .
  692.        move nein to game-over .
  693.        perform ziehe-teil .
  694.        perform with test after until game-over = ja
  695.           perform zeichne-teil
  696.           move 0 to taste-zaehler
  697.           perform with test after
  698.            until taste-zaehler > level-zaehler
  699.               or taste = fallen
  700.          perform hole-taste
  701.          evaluate taste
  702.          when links
  703.             perform move-teil-links
  704.          when rechts
  705.             perform move-teil-rechts
  706.          when rotieren
  707.             perform rotiere-teil
  708.          when fallen
  709.             perform drop-teil
  710.          when abbruch
  711.             perform ende
  712.          when any
  713.       *Wenn keine Taste gedrückt wurde, wird auch nichts getan. Wenn man
  714.       *also Lust hat, kann man statt dessen auch noch etwas anzeigen.
  715.       *Wie wäre es mit der Uhrzeit oben rechts ??????? Nur den Inhalt
  716.       *des Paragraphen ändern!
  717.             perform dummy-exit
  718.          end-evaluate
  719.          add 1 to taste-zaehler
  720.           end-perform
  721.       *Generell wird das Teil gesenkt wenn es nicht fallengelassen wurde
  722.           if taste not = fallen
  723.          perform senke-teil
  724.           end-if
  725.        end-perform .
  726.        end-abfrage .
  727.        display "G A M E   O V E R !             "
  728.                    at line 16 column 44 .
  729.        display "Start eines neuen Spiels:       "
  730.                    at line 17 column 44 .
  731.        display "<1> bis <9> startet Level       "
  732.                    at line 18 column 44 .
  733.        display "Ende mit <0>                    "
  734.                    at line 19 column 44 .
  735.       *Auch hier wieder. Es gibt in COBOL kein INKEY
  736.        move 0 to waitkey .
  737.        move " " to nochmal-taste
  738.        perform until nochmal-taste not < "0" and not > "9"
  739.           call "CBL_GET_KBD_STATUS" using waitkey
  740.           if waitkey = 1
  741.          call "CBL_READ_KBD_CHAR" using nochmal-taste
  742.           end-if
  743.        end-perform
  744.       *Als erstes die Sicherheitsabfrage, die Taste auch wirklich
  745.       *Numerisch ist. Wenn Ja und die Taste liegt zwischen 1 und 9
  746.       *wird der Level gesetzt oder durch die Variable again wird das
  747.       *das Programm beendet.
  748.        if nochmal-taste numeric
  749.           if nochmal-taste not = "0"
  750.          move nochmal-taste to level
  751.           else
  752.          move nein to again
  753.           end-if
  754.        else
  755.           move nein to again
  756.        end-if .
  757.        ask-defaults .
  758.        perform clear-screen .
  759.        move 0 to level .
  760.        move 0 to pc-faktor .
  761.        display "Willkommen zu TX-TRIS!" AT line 1 column 1 .
  762.        display "Bitte geben Sie den Verzoegerungsfaktor fuer Ihren
  763.       -"Rechner ein" at line 2 column 1 .
  764.        display "Je hoeher der Wert, desto langsamer wird das Spiel"
  765.           at line 3 column 1 .
  766.        perform until pc-faktor > 0 and not > 30000
  767.           display "Verzoegerung von 1 bis 30000 " at Line 5
  768.                              column 1
  769.           accept pc-faktor
  770.        end-perform
  771.        perform until level > 0 and < 10
  772.           display "Mit welchem Level wollen Sie starten 1 bis 9 "
  773.           at line 7 column 1
  774.           accept level
  775.        end-perform .
  776.        initialisieren-fallteile .
  777.       *Andere Programmiersprachen können eine Tabelle komplett mit
  778.       *Werten bestücken. Dieser Aufwand lohnt sich nicht immer in
  779.       *COBOL. Nur bei kleineren Tabellen ist dies sinnvoll (siehe
  780.       * auch die Tabelle Teily1-Offset).
  781.        move "        " to teilreihe (1,1,1)
  782.        move "        " to teilreihe (1,1,2)
  783.        move "XXXXXX  " to teilreihe (1,1,3)
  784.        move "    XX  " to teilreihe (1,1,4)
  785.        move "        " to teilreihe (1,2,1)
  786.        move "  XXXX  " to teilreihe (1,2,2)
  787.        move "  XX    " to teilreihe (1,2,3)
  788.        move "  XX    " to teilreihe (1,2,4)
  789.        move "        " to teilreihe (1,3,1)
  790.        move "XX      " to teilreihe (1,3,2)
  791.        move "XXXXXX  " to teilreihe (1,3,3)
  792.        move "        " to teilreihe (1,3,4)
  793.        move "        " to teilreihe (1,4,1)
  794.        move "    XX  " to teilreihe (1,4,2)
  795.        move "    XX  " to teilreihe (1,4,3)
  796.        move "  XXXX  " to teilreihe (1,4,4)
  797.        move "        " to teilreihe (2,1,1)
  798.        move "        " to teilreihe (2,1,2)
  799.        move "@@@@@@  " to teilreihe (2,1,3)
  800.        move "@@      " to teilreihe (2,1,4)
  801.        move "        " to teilreihe (2,2,1)
  802.        move "  @@    " to teilreihe (2,2,2)
  803.        move "  @@    " to teilreihe (2,2,3)
  804.        move "  @@@@  " to teilreihe (2,2,4)
  805.        move "        " to teilreihe (2,3,1)
  806.        move "    @@  " to teilreihe (2,3,2)
  807.        move "@@@@@@  " to teilreihe (2,3,3)
  808.        move "        " to teilreihe (2,3,4)
  809.        move "        " to teilreihe (2,4,1)
  810.        move "  @@@@  " to teilreihe (2,4,2)
  811.        move "    @@  " to teilreihe (2,4,3)
  812.        move "    @@  " to teilreihe (2,4,4)
  813.        move "        " to teilreihe (3,1,1)
  814.        move "  $$$$  " to teilreihe (3,1,2)
  815.        move "$$$$    " to teilreihe (3,1,3)
  816.        move "        " to teilreihe (3,1,4)
  817.        move "        " to teilreihe (3,2,1)
  818.        move "$$      " to teilreihe (3,2,2)
  819.        move "$$$$    " to teilreihe (3,2,3)
  820.        move "  $$    " to teilreihe (3,2,4)
  821.        move "        " to teilreihe (3,3,1)
  822.        move "  $$$$  " to teilreihe (3,3,2)
  823.        move "$$$$    " to teilreihe (3,3,3)
  824.        move "        " to teilreihe (3,3,4)
  825.        move "        " to teilreihe (3,4,1)
  826.        move "$$      " to teilreihe (3,4,2)
  827.        move "$$$$    " to teilreihe (3,4,3)
  828.        move "  $$    " to teilreihe (3,4,4)
  829.        move "        " to teilreihe (4,1,1)
  830.        move "####    " to teilreihe (4,1,2)
  831.        move "  ####  " to teilreihe (4,1,3)
  832.        move "        " to teilreihe (4,1,4)
  833.        move "        " to teilreihe (4,2,1)
  834.        move "  ##    " to teilreihe (4,2,2)
  835.        move "####    " to teilreihe (4,2,3)
  836.        move "##      " to teilreihe (4,2,4)
  837.        move "        " to teilreihe (4,3,1)
  838.        move "####    " to teilreihe (4,3,2)
  839.        move "  ####  " to teilreihe (4,3,3)
  840.        move "        " to teilreihe (4,3,4)
  841.        move "        " to teilreihe (4,4,1)
  842.        move "  ##    " to teilreihe (4,4,2)
  843.        move "####    " to teilreihe (4,4,3)
  844.        move "##      " to teilreihe (4,4,4)
  845.        move "        " to teilreihe (5,1,1)
  846.        move "  [[[[  " to teilreihe (5,1,2)
  847.        move "  [[[[  " to teilreihe (5,1,3)
  848.        move "        " to teilreihe (5,1,4)
  849.        move "        " to teilreihe (5,2,1)
  850.        move "  [[[[  " to teilreihe (5,2,2)
  851.        move "  [[[[  " to teilreihe (5,2,3)
  852.        move "        " to teilreihe (5,2,4)
  853.        move "        " to teilreihe (5,3,1)
  854.        move "  [[[[  " to teilreihe (5,3,2)
  855.        move "  [[[[  " to teilreihe (5,3,3)
  856.        move "        " to teilreihe (5,3,4)
  857.        move "        " to teilreihe (5,4,1)
  858.        move "  [[[[  " to teilreihe (5,4,2)
  859.        move "  [[[[  " to teilreihe (5,4,3)
  860.        move "        " to teilreihe (5,4,4)
  861.        move "        " to teilreihe (6,1,1)
  862.        move "]]]]]]]]" to teilreihe (6,1,2)
  863.        move "        " to teilreihe (6,1,3)
  864.        move "        " to teilreihe (6,1,4)
  865.        move "  ]]    " to teilreihe (6,2,1)
  866.        move "  ]]    " to teilreihe (6,2,2)
  867.        move "  ]]    " to teilreihe (6,2,3)
  868.        move "  ]]    " to teilreihe (6,2,4)
  869.        move "        " to teilreihe (6,3,1)
  870.        move "]]]]]]]]" to teilreihe (6,3,2)
  871.        move "        " to teilreihe (6,3,3)
  872.        move "        " to teilreihe (6,3,4)
  873.        move "  ]]    " to teilreihe (6,4,1)
  874.        move "  ]]    " to teilreihe (6,4,2)
  875.        move "  ]]    " to teilreihe (6,4,3)
  876.        move "  ]]    " to teilreihe (6,4,4)
  877.        move "        " to teilreihe (7,1,1)
  878.        move "        " to teilreihe (7,1,2)
  879.        move "******  " to teilreihe (7,1,3)
  880.        move "  **    " to teilreihe (7,1,4)
  881.        move "        " to teilreihe (7,2,1)
  882.        move "  **    " to teilreihe (7,2,2)
  883.        move "  ****  " to teilreihe (7,2,3)
  884.        move "  **    " to teilreihe (7,2,4)
  885.        move "        " to teilreihe (7,3,1)
  886.        move "  **    " to teilreihe (7,3,2)
  887.        move "******  " to teilreihe (7,3,3)
  888.        move "        " to teilreihe (7,3,4)
  889.        move "        " to teilreihe (7,4,1)
  890.        move "  **    " to teilreihe (7,4,2)
  891.        move "****    " to teilreihe (7,4,3)
  892.        move "  **    " to teilreihe (7,4,4) .
  893.        DUMMY-EXIT .
  894.       *Diese Routine hat im Augenblick keinen Wert, kann aber erweitert
  895.       *werden.
  896.        exit .
  897.