From lennartb@lne.kth.se Thu Aug  9 11:51:52 1990
From: lennartb@lne.kth.se (Lennart Boerjeson @ KTH/LNE, The Royal Inst. of Tech.)
Newsgroups: comp.sys.handhelds
Subject: Tetris
Date: 8 Aug 90 12:16:29 GMT
Reply-To: lennartb@lne.kth.se (Lennart Boerjeson @ KTH/LNE, The Royal Inst. of Tech.)
Organization: KTH School of E.E.

This is Tetris for the HP48. The program is quite big.

Before loading this program, be sure to pack all GROBs on one line.
Start the game by selecting CST menu and press TETRIS. Exit the introduction
by hitting any key, except ON.
Use the cursor keys to move the falling object.
Rotate by pressing UP-arrow, drop by pressing DOWN-arrow.
NXT toggles display of next object.
RUBOUT exits game.

Flaws: I have no idea of how the original Tetris awards points. If someone
has, please mail me.

!++
! Lennart Boerjeson, System Manager
! School of Electrical Engineering
! Royal Institute of Technology
! S-100 44 Stockholm, Sweden
! tel: int+46-8-7907814
! Internet: lennartb@lne.kth.se
!--


%%HP: T(3)A(R)F(,);
DIR
  BLROW GROB 30 3 000000000000000000000000
  CHECKROWS
    \<< XY DXY + IM OB SIZE SWAP DROP B\->R 1 - 3 / IP NEG OVER +
      FOR y y CHKROW -1
      STEP
    \>>
  CHKP
    \<< 'NXY' STO NXY DXY + PIC OVER OB
      IFERR GXOR
      THEN 4 DROPN 0
      ELSE 'NPIC' STO PIC SWAP OB GOR NPIC SAME
      END
    \>>
  CHKP1
    \<< DXY + PIC OVER OB GXOR PIC ROT OB GOR SAME
    \>>
  CHKPLOOP
    \<<
      DO XY VL + CHKP
        IF
        THEN 1 DUP
        ELSE
          IF VL RE DUP
          THEN SIGN 0 R\->C NEG 'VL' STO+ 0
          ELSE 1
          END
        END
      UNTIL
      END
    \>>
  CHKROW
    \<< -5 SWAP R\->C PIC SWAP (29;-2) 3 / OVER + \-> A B
      \<< A B SUB ROWOB
        IF SAME
        THEN PIC A BLROW REPL 'PIC' STO
          PV
          PIC (-5;18) PIC (-5;19) B (0;1) + SUB REPL
          (-5;19) BLROW REPL 'PIC' STO
	  500 PTPLUS
          PV
        END
      \>>
    \>>
  CST { TETRIS INTRO MOVIE }
  DROPOB
    \<< UNPASTE
      IF CHKPLOOP
      THEN
        DO (0;-1) 'VL' STO+
        UNTIL XY VL + CHKP1 NOT
        END (0;1) 'VL' STO+
      END PASTE
    \>>
  DXY (-1;0)
  FLGS { # 84030000050FF0h # 0h }
  GETOB
    \<< NOBJ 'OBJ' STO NOBN 'OBN' STO NOB 'OB' STO
      (0;18) 'XY' STO MDXY RANDOBJ
    \>>
  GOVER "Game over"
  INIPIC
    \<< (-16;-3) 3 / (15;60) 3 / { X 0 (0;0) FUNCTION Y } + + 'PPAR' STO
      ERASE PICT { # 31h # 0h } { # 50h # 3Fh } DUP2 BOX SUB 'PIC' STO
      PICT { # 58h # 4h } VASILIJ REPL PICT { # 2h # Ah } INSTR REPL
    \>>
  INITT
    \<< INIPIC { # 0h # 0h } PVIEW RANDOBJ GETOB PASTE 'NV=0' DEFINE
      'PT=0' DEFINE PV 'VL=(0;-1)' DEFINE
    \>>
  INSTR GROB 38 50 CCD9CD10004594940000C49C9C100045949400004D949C
    10000000000000000000000000CF1000000042100000004710000000CA100
    0000042100000004210000000CF10000000000000008FDFDF000084525900
    0082525A00008FDADF000082575A000084525900008FDFDF0000000000000
    000000000000CCCD10000045551000004D4D1000004555000000C4D500000
    00000000000000000000FFFF00000010080000005AAB04ABA3DA290CA821D
    3190CB3115B2904B8215A2904AB211008000000FFFF0000000000000000FF
    FFF000001000800000199A989AE098AAA4AA40DB9A94AA4098AAA49A4019A
    B98AB401000800000FFFFF00000
  INTRO
    \<<
      IF 'MOVIE' VTYPE 15 SAME
      THEN MOVIE MOV UPDIR
      END
    \>>
  KEYACT
    \<<
      CASE DUP 25 SAME
        THEN ROTATEOB
        END DUP 35 SAME
        THEN DROPOB
        END DUP 34 SAME
        THEN LEFTOB
        END DUP 36 SAME
        THEN RIGHTOB
        END DUP 26 SAME
        THEN NV NOT 'NV' STO
        END DUP 55 SAME
        THEN DROP GOVER DOERR
        END 1000 ,1 BEEP
      END DROP
    \>>
  LEFTOB
    \<< (-1;0) 'VL' STO+
    \>>
  MDXY
    \<< OB SIZE 7 / B\->R SWAP 6 / B\->R NEG SWAP R\->C 'DXY' STO
    \>>
  MOVACT
    \<< UNPASTE
      IF CHKPLOOP
      THEN UPD
      ELSE PASTE CHECKROWS GETOB
        IF XY CHKP
        THEN UPD
        ELSE GOVER DOERR
        END
      END PV (0;-1) 'VL' STO
    \>>
  MOVIE
    DIR
      CST { }
      INIMOV
        \<< PICT SIZE 'PH' STO 'OPW' STO PLANE SIZE 'SH' STO 'SW' STO
          OPW SW + 'PW' STO PW PH BLANK SW # 0h 2 \->LIST PICT RCL REPL
          'PIC' STO PIC PICT STO
        \>>
      INIXY
        \<< SW OPW SW - 2 / + B\->R 'X' STO PH SH - 2 / 'Y' STO
        \>>
      MOV
        \<< REDSQ PICT STO INIMOV INIXY SW # 0h 2 \->LIST PVIEW
          DO PW 1 - B\->R 0
            FOR x x R\->B Y 2 \->LIST 'XY' STO
              PICT O PIC XY PLANE GOR XY NPLANE GXOR REPL -10
            STEP PICT O PIC REPL
          UNTIL KEY
          END DROP RSTXY RSTMOV
        \>>
      NPLANE GROB 83 11 00000C708FFFFFFFFFFF7008F0064040000000000040
        7C810A502FFFFFFFFFFF50D7770B5051DB5F1119D450500CFDDF65D55FBD
        B557509FF3000051D1BFB1B9D6509FF30CFF6DD5BFBDB5DD50970CF7005D
        15BFB1B5565058F700002FFFFFFFFFFF50DF000000400000000000407000
        00008FFFFFFFFFFF70
      O { # 0h # 0h }
      PLANE GROB 83 11 00000C708FFFFFFFFFFF7008F00E70CFFFFFFFFFFF707
        CF10E70EFFFFFFFFFFF70FFF70F70FFFFFFFFFFFF70FFFFFFFFFFFFFFFFF
        FFF70FFFFFFFFDFFFFFFFFFFF70FFFFFFFFFFFFFFFFFFFF70FFFFF700FFF
        FFFFFFFFF70FFF70000EFFFFFFFFFFF70FF000000CFFFFFFFFFFF7070000
        0008FFFFFFFFFFF70
      PPAR { (-6,5;-3,1) (6,5;3,2) X 0 (0;0) FUNCTION Y }
      REDSQ GROB 131 64 00000000000000002000000000000000000000000000
        0000002000000000000000000000000000000008F0000000000000000000
        000000000000002000000000000000000000000000000000600000000000
        000000000000000000000030000000000000000000000000000000002000
     	000000000000000000000000000000500000000000000000000000000000
	000880000000000000000000000000000000040100000000000000000000
	000000000004010000000000000000000000000000000880000000000000
	000000000000000000007000000000000000000000000000000000500000
	000000000000000000000000000050000000000000000000000000000000
	005000000000000000000000000000000000700000000000000000000000
	0000000408A000000000000000000000000000000408A000000000000000
	000000000000000F18A000000000000000000000000000000408A0800000
	00000000000000000000000C442180000000000000000000000000000644
	21E30000000000000000000000000004F521800000000000000000000000
	0000044EF381000002000000000000000000000AC282C000000200000000
	0000000000000A628280000007000000000000000000000542E3800000CF
	100000000000000000000552824100008F0000000000000000000084E283
	410000070000000000000000000042F2C2A200008A000000000000000000
	00495182A200000200000000000000000000C45182940000050000000000
	00000000004A534929000005000000000000000000008755C94A00008800
	00000000000000000084556B9C000088000000000000000000008455AA29
	0000CF10000000000000000000845555F70000CF10000000007511000000
	88F3B6140000CA100000000015B1000000880255140000CE100000000015
	510000008F02E3F70000C81000000000151100000088022A080000CF1000
	000000171100000088F32EFF10004710000000F700000000008404E70010
	004010000F7008FFF30000004404140010004018FFFF7000000CFF100042
	0808001000CFFFFFFF70333000001000CFFFFFFF1000CFFFFFFF70000333
	3B1000629429423000CFFFFFFF70000000001000529429425000CFFFFFFF
	70000000001008FFFFFFFFF000CFFFFFFF703333333B1008000880008000
	CFFFFFFF70000000001008000401008000CFFFFFFF700000033B10080004
	01008000CFFFFFFF70003330001008000401008000CFFFFFFF703300000B
	1008000401008000CFFFFFFF70000003301008FFFFFFFFF000CFFFFFFF70
	0003300CFFFFFFFFFFFFFFFFFFFFFFFF70033000E300000000000000000E
	FFFFFF7030008F1002DD989B38BBBBC200CFFFFF70000C70000A54510900
	909A220000FFFF7000E300000E5CD52930939B2200000EFF708F10000006
	54453900909820000000CF707000000002544D29309398C2000000007000
	00000000000000000000000000000000
      RSTMOV
        \<< PIC SW # 0h 2 \->LIST PW 1 - PH 1 - 2 \->LIST SUB
          PICT CLLCD TEXT STO { PIC PW SW SH OPW PH } PURGE
          WHILE KEY
          REPEAT DROP
          END
        \>>
      RSTXY
        \<< { X Y XY } PURGE
        \>>
    END
  NEWG?
    \<< RCLMENU \-> m 
      \<< { { YES \<< 0 CONT \>> } { NO \<< 1 CONT \>> } } TMENU
        2 FREEZE "Play again?" PROMPT m MENU
      \>>
    \>>
  NOB GROB 6 6 F3D2F3F3D2F3
  NOBJ { GROB 6 6 F3D2F3F3D2F3
         GROB 6 6 F3D2F3F3D2F3
	 GROB 6 6 F3D2F3F3D2F3
	 GROB 6 6 F3D2F3F3D2F3
       }
  NOBN 2
  NPIC GROB 32 64 FFFFFFFF100000081000000810000008100000081000000810
	0070081000500810007008100EF308100AD208100EF30810000008100000
	081000000810000008100000081000000810000008100000081000000810
	000008100000081000000810000008100000081000000810000008100000
	081000000810000008100000081000000810000008100000081000000810
	000008100000081000000810000008100000081000000810000008100000
	081000000810000008100000081000000810000008100000081000000810
	0000081000000810000008F700000FB500000DF700000FFF30000FBD2000
	0DFF30000FFF3000EFBD2000ADFF3000EFFFFFFFFF
  NV 0
  NXY (0;18)
  OB GROB 9 6 830082008300FF10D610FF10
  OBJ { GROB 9 6 830082008300FF10D610FF10
        GROB 6 9 838283F3D2F3838283
        GROB 9 6 FF10D610FF10830082008300
        GROB 6 9 705070F3D2F3705070
      }
  OBLIST { :L2OBJ:  { GROB 6 9 705070705070F3D2F3
                      GROB 9 6 0C1004100C10FF10D610FF10
                      GROB 6 9 F3D2F3838283838283
                      GROB 9 6 FF10D610FF10700050007000
                    }
           :L1OBJ:  { GROB 6 9 838283838283F3D2F3
                      GROB 9 6 FF10D610FF100C1004100C10
                      GROB 6 9 F3D2F3705070705070
                      GROB 9 6 700050007000FF10D610FF10
                    }
           :Z1OBJ:  { GROB 9 6 8F1086108F10F300D200F300
                      GROB 6 9 705070F3D2F3838283
                      GROB 9 6 8F1086108F10F300D200F300
                      GROB 6 9 705070F3D2F3838283
                    }
           :Z2OBJ:  { GROB 9 6 F300D200F3008F1086108F10
                      GROB 6 9 838283F3D2F3705070
                      GROB 9 6 F300D200F3008F1086108F10
                      GROB 6 9 838283F3D2F3705070
                    }
           :TOBJ:   { GROB 9 6 830082008300FF10D610FF10
                      GROB 6 9 838283F3D2F3838283
                      GROB 9 6 FF10D610FF10830082008300
                      GROB 6 9 705070F3D2F3705070
                    }
           :ROBJ:   { GROB 12 3 FFF0D6B0FFF0
                      GROB 3 12 705070705070705070705070
                      GROB 12 3 FFF0D6B0FFF0
                      GROB 3 12 705070705070705070705070
                    }
           :SOBJ:   { GROB 6 6 F3D2F3F3D2F3
                      GROB 6 6 F3D2F3F3D2F3
                      GROB 6 6 F3D2F3F3D2F3
                      GROB 6 6 F3D2F3F3D2F3
                    } }
  OBN 1
  PASTE
    \<< PIC XY DXY + OB GXOR 'PIC' STO
    \>>
  PIC GROB 32 64 FFFFFFFF1000000810000008100000081000000810000008100
	070081000500810007008100EF308100AD208100EF308100000081000000
	810000008100000081000000810000008100000081000000810000008100
	000081000000810000008100000081000000810000008100000081000000
	810000008100000081000000810000008100000081000000810000008100
	000081000000810000008100000081000000810000008100000081000000
	810000008100000081000000810000008100000081000000810000008100
	000081000000810000008F700000FB500000DF700000FFF30000FBD20000
	DFF30000FFF3000EFBD2000ADFF3000EFFFFFFFFF
  PPAR { (-5,33333333333;-1) (5;20) X 0 (0;0) FUNCTION Y }
  PT 440
  PTPLUS
    \<< 'PT' STO+
    \>>
  PV
    \<< PICT { # 0h # 0h } PICT RCL { # 31h # 0h } PIC
      REPL { # 6h # 2h } PT 1 \->GROB REPL { # 20h # 2h }
      # Ch # Ch BLANK REPL
      IF NV
      THEN { # 20h # 2h } NOB REPL
      END REPL
    \>>
  RANDOBJ
    \<< OBLIST DUP SIZE RAND * IP 1 + GET DTAG 'NOBJ' STO
      RAND 4 * 1 + IP 'NOBN' STO NOBJ NOBN GET 'NOB' STO
    \>>
  RESETFLGS
    \<< FLGS STOF
    \>>
  RIGHTOB
    \<< (1;0) 'VL' STO+
    \>>
  ROTATEOB
    \<< UNPASTE DXY OB OBJ OBN 4 MOD 1 + 'OBN' STO
      OBJ OBN GET 'OB' STO MDXY
      IF ROTCHK
      THEN UPD 3 DROPN
      ELSE 'OBJ' STO 'OB' STO 'DXY' STO PASTE
      END
    \>>
  ROTCHK
    \<< OB SIZE DROP 3 / B\->R \-> w
      \<< [ (0;0) (1;0) (-1;0) (2;0) (0;0) ] 1
        DO
          IF DUP w >
          THEN 0 1
          ELSE GETI DUP 'DXY' STO+
            IF XY CHKP
            THEN DROP 1 1
            ELSE NEG 'DXY' STO+ 0
            END
          END
        UNTIL
        END 3 ROLLD DROP2
      \>>
    \>>
  ROWOB GROB 30 3 FFFFFFF3D6BD6BD2FFFFFFF3
  SCORE
    \<< CLLCD GOVER 1 DISP "Your score: " PT + 3 DISP TEXT 5 WAIT
    \>>
  SETFLGS
    \<< RCLF 'FLGS' STO { # 4030000050FF0h # 0h } STOF
    \>>
  TETRIS
    \<< SETFLGS INTRO
      DO INITT
        IFERR
          WHILE 1
          REPEAT
            DO MOVACT
            UNTIL KEY
            END
            DO KEYACT
            UNTIL KEY NOT
            END
          END
        THEN
          IF ERRM GOVER \=/
          THEN RESETFLGS ERRN DOERR
          END
        END SCORE
      UNTIL NEWG?
      END RESETFLGS
    \>>
  UNPASTE
    \<< PIC XY DXY + OB GXOR 'PIC' STO
    \>>
  UPD
    \<< NPIC 'PIC' STO NXY 'XY' STO 10 PTPLUS
    \>>
  VASILIJ
    \<<
      IF 'MOVIE' VTYPE 15 SAME
      THEN { MOVIE REDSQ } RCL { # 2Fh # 0h } { # 53h # 37h } SUB
      ELSE BLROW
      END
    \>>
  VL (0;-1)
  XY (0;18)
END
!++
! Lennart Boerjeson, System Manager
! School of Electrical Engineering
! Royal Institute of Technology
! S-100 44 Stockholm, Sweden
! tel: int+46-8-7907814
! Internet: lennartb@lne.kth.se
!--