[原创]俄罗斯方块 — 编程爱好者社区

沙发

QB71 [专家分：1300] 发布于 2005-01-17 13:36:00

DECLARE FUNCTION MsgBox% (stil$)
DECLARE SUB GameOver ()
DECLARE SUB BlGet (e AS ANY)
DECLARE SUB BlClear ()
DECLARE SUB BlDraw ()
DECLARE SUB BlInit ()
DECLARE SUB Is.CanDown ()
DECLARE SUB Is.CanLeft ()
DECLARE SUB Is.CanRight ()
DECLARE SUB Is.CanTurnLeft ()
DECLARE SUB Is.CanTurnRight ()
DECLARE SUB MyPrn (X%, Y%, st$, bfclr%, bkclr%, over%)
DECLARE SUB Set.Palete ()
DECLARE SUB SysInit ()
DECLARE SUB Turn.Left (e AS ANY)
DECLARE SUB Turn.Right (e AS ANY)
DECLARE SUB Up.Pset (X%, Y%)
DECLARE SUB XYClear ()
DECLARE SUB XYSet ()
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'          定义变量
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
TYPE BlType               '方块
     Wid AS INTEGER       '宽度
     Hei AS INTEGER       '高度
     Bit AS STRING * 6    '形状
END TYPE
'-------------------------------
'按键值
CONST KeyLeft% = 75, KeyRight% = 77, KeyDown% = 80, KeyA% = 65
CONST KeyS% = 83, KeyEsc% = 27, KeySpace% = 32, KeyPgDn% = 81, KeyPgUp% = 73
'-------------------------------
CONST False = 0, True = NOT False   '真假值
CONST Bgnx% = 10, Bgny% = 0         '方块初始位置
CONST BackClr% = 10                 '背景色
CONST bordx% = 60, Bordy% = 50     '桶左上边界
CONST Pexx% = 16, Pexy% = 16        '方块高宽
CONST Hei% = 24, Wid% = 24          '桶高宽
DIM SHARED Works  AS LONG           '积分数
DIM SHARED Fast%                    '方块下落的速度
DIM SHARED BPic(32) AS LONG         '方块样式
REDIM SHARED Xy(Hei%, Wid%) AS INTEGER'桶方块数据
DIM SHARED Bl(11) AS BlType         '方块形状数组
DIM SHARED CurBl AS BlType          '当前方块
DIM SHARED NextBl AS BlType         '下一方块
DIM SHARED Blx%, Bly%               '当前方块位置
DIM SHARED Staring%                 '游戏是否开始变量
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
DEFINT A-Z
SCREEN 12
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'程序开始了
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Fast% = 10
SysInit
BlInit         '初始化方块
DEF SEG = 65
WHILE Quit% = False       '等待按键
   '---------------------------------------
   NewTime% = PEEK(92)    '取时间间隔
   IF OldTime% > NewTime% THEN OldTime% = 0
   IF NewTime% > OldTime% + Fast% AND Staring% THEN
       OldTime% = NewTime%
       Is.CanDown
   END IF
   '---------------------------------------
   ikey$ = INKEY$: KeyCode% = -1    '取按键
   IF ikey$ <> "" THEN
       IF LEN(ikey$) = 2 THEN
            KeyCode% = ASC(MID$(ikey$, 2, 1))
            ELSE : KeyCode% = ASC(UCASE$(ikey$))
       END IF
   END IF
   '---------------------------------------
   IF KeyCode% > 0 THEN             '处理按键
       SELECT CASE KeyCode%
           CASE KeyLeft%            '左移
                IF Staring% THEN CALL Is.CanLeft
           CASE KeyRight%           '右移
                IF Staring% THEN CALL Is.CanRight
           CASE KeyDown%            '下落
                IF Staring% THEN CALL Is.CanDown
           CASE KeyA%               '左旋转
                IF Staring% THEN CALL Is.CanTurnLeft
           CASE KeyS%               '右旋转
                IF Staring% THEN CALL Is.CanTurnRight
           CASE KeyEsc%             '退出程序
                Quit% = True
           CASE KeySpace%           '暂停/开始
                Staring% = NOT Staring%
           CASE KeyPgDn%            '减速
                IF Fast% < 10 THEN
                   Fast% = Fast% + 1
                   M$ = LTRIM$(RTRIM$(STR$(10 - Fast%)))
                   LINE (500, 390)-(520, 407), BackClr%, BF
                   MyPrn 501, 391, M$, 13, BackClr%, 0
                   MyPrn 500, 390, M$, 4, 0, 0
                END IF
           CASE KeyPgUp%            '加速
                IF Fast% > 0 THEN
                   Fast% = Fast% - 1
                   M$ = LTRIM$(RTRIM$(STR$(10 - Fast%)))
                   LINE (500, 390)-(520, 407), BackClr%, BF
                   MyPrn 501, 391, M$, 13, BackClr%, 0
                   MyPrn 500, 390, M$, 4, 0, 0
                END IF
       END SELECT
   END IF
   '---------------------------------------
WEND
END
DATA 0,0,0,0,0,0,0,0,0,64,0,48,0,60,63,254,0,60,0,48,0,64,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,1,0,6,0,30,0,63,254,30,0,6,0,1,0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,128,0,128,0,128,0,128,0,128,0,128,0,128,0,128,4,144,3,224,3,224,1,192,1,192,0,128,0,0
DATA 17,0,17,0,17,0,35,252,34,4,100,8,168,64,32,64,33,80,33,72,34,76,36,68,32,64,32,64,33,64,32,128
DATA 1,0,17,0,17,0,17,16,31,248,33,0,65,0,1,4,255,254,1,0,2,128,2,128,4,64,8,48,16,14,96,4
DATA 4,64,126,64,68,68,84,126,84,136,85,8,84,72,84,72,84,72,84,80,84,80,16,32,40,80,36,142,69,4,130,0
DATA 0,0,127,248,0,16,0,32,0,64,1,128,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,5,0,2,0
DATA 16,64,16,32,16,0,19,254,250,2,20,68,16,64,63,254,208,136,16,136,17,8,16,144,16,96,16,80,80,140,35,4
DATA 16,32,18,32,34,32,35,36,74,172,250,112,18,32,35,252,66,32,250,112,66,172,3,36,26,32,226,36,67,254,0,0
DATA 16,64,16,80,35,248,32,64,72,64,255,252,17,36,32,168,66,32,249,36,7,254,0,64,28,96,224,144,65,12,2,4
DATA 3,248,66,8,50,8,19,248,2,8,2,8,243,252,18,8,18,208,18,32,18,144,19,12,18,4,40,0,68,6,3,252
DATA 1,0,1,0,33,8,33,8,33,8,33,8,63,248,33,8,1,0,65,4,65,4,65,4,65,4,65,4,127,252,64,4
DATA 16,16,8,24,4,32,4,72,127,252,1,0,1,0,1,4,255,254,1,0,2,128,2,128,4,64,8,48,48,14,192,4
DATA 2,0,2,32,3,240,2,0,2,0,2,4,255,254,2,0,2,0,2,128,2,96,2,48,2,16,2,0,2,0,2,0
DATA 4,0,14,4,120,254,8,132,8,132,254,132,8,132,24,132,28,252,42,132,40,0,72,136,136,196,9,6,10,2,8,0
DATA 0,128,4,128,4,64,8,64,8,32,16,16,32,8,79,238,132,36,4,32,4,32,4,32,4,32,8,32,17,64,32,128
DATA 16,0,16,0,16,4,18,126,255,68,18,68,18,68,18,68,18,68,34,68,34,68,34,68,34,68,74,124,132,68,0,0
DATA 16,128,16,128,16,128,16,136,91,252,84,136,80,136,144,136,16,136,31,254,16,128,17,64,17,32,18,16,20,14,24,4
DATA 0,16,64,24,48,20,23,254,4,16,4,16,13,208,20,20,37,212,229,84,37,84,37,88,37,208,37,42,8,70,16,130
DATA 19,248,18,8,19,248,90,8,87,248,80,4,151,254,20,164,20,164,23,252,16,0,19,248,17,16,16,224,17,24,22,6
DATA 0,4,255,254,2,0,2,0,2,0,2,128,2,64,2,48,2,16,2,0,2,0,2,0,2,0,2,0,2,0,2,0
DATA 8,32,8,36,255,254,9,32,65,248,35,16,36,160,128,64,73,176,18,14,47,252,226,8,34,8,34,8,35,248,34,8
DATA 2,0,2,0,2,4,255,254,4,0,4,0,8,0,8,8,31,252,40,8,72,8,136,8,8,8,8,8,15,248,8,8
DATA 8,64,28,64,240,252,17,132,18,72,252,48,16,96,57,160,52,62,84,66,144,196,17,36,16,24,16,48,16,192,23,0
DATA 2,0,2,0,2,8,255,252,4,0,4,0,4,0,8,16,15,248,16,128,16,128,32,128,64,128,128,132,127,254,0,0
DATA 8,32,9,168,15,36,17,32,17,36,63,254,81,32,145,32,17,164,19,24,29,16,17,48,17,72,17,138,21,6,18,2
DATA 0,4,127,254,68,68,68,68,68,68,127,252,66,4,2,0,7,240,8,16,20,32,98,192,1,0,6,0,24,0,224,0
DATA 34,8,34,28,127,96,34,64,34,64,62,64,34,126,34,72,62,72,34,72,34,72,255,72,0,136,21,8,34,8,64,8
DATA 4,0,3,0,1,0,0,4,255,254,4,0,4,16,7,248,4,16,4,16,4,16,8,16,8,16,16,16,32,160,64,64
DATA 16,128,16,128,16,128,16,136,19,252,252,136,16,136,16,136,16,136,23,254,28,128,241,64,65,32,2,16,4,14,8,4
DATA 8,64,28,64,240,64,16,64,17,68,253,76,17,80,50,64,56,64,84,160,80,160,145,16,17,8,18,14,20,4,24,0
DATA 0,16,63,248,32,16,40,80,36,80,34,144,34,144,33,16,33,16,34,144,34,144,36,80,40,80,48,18,64,10,128,6
DATA 16,12,126,240,16,128,40,132,126,254,8,144,254,144,9,16,10,16,0,16,31,248,16,16,31,240,16,16,31,240,16,16
DATA 16,128,16,72,23,252,32,0,35,248,98,8,163,248,32,0,47,254,40,2,51,244,32,64,32,64,32,64,33,64,32,128
DATA 0,8,127,252,8,32,8,32,8,32,8,32,8,36,255,254,8,32,8,32,8,32,8,32,16,32,16,32,32,32,64,32
DATA 16,64,16,64,16,64,16,128,252,136,37,4,39,254,36,2,36,4,73,254,41,4,17,4,41,4,69,4,133,252,1,4
DATA 32,128,16,132,20,254,254,128,33,0,34,254,60,34,36,36,36,160,36,168,36,188,36,160,68,160,85,96,138,38,4,28
DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,4,255,254,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
'---------------------------------------------
DATA 0,0,56,108,198,198,214,214,198,198,108,56,0,0,0,0
DATA 0,0,24,56,120,24,24,24,24,24,24,126,0,0,0,0
DATA 0,0,124,198,6,12,24,48,96,192,198,254,0,0,0,0
DATA 0,0,124,198,6,6,60,6,6,6,198,124,0,0,0,0
DATA 0,0,12,28,60,108,204,254,12,12,12,30,0,0,0,0
DATA 0,0,254,192,192,192,252,6,6,6,198,124,0,0,0,0
DATA 0,0,56,96,192,192,252,198,198,198,198,124,0,0,0,0
DATA 0,0,254,198,6,6,12,24,48,48,48,48,0,0,0,0
DATA 0,0,124,198,198,198,124,198,198,198,198,124,0,0,0,0
DATA 0,0,124,198,198,198,126,6,6,6,12,120,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,24,24,24,48,0,0,0
DATA 0,0,0,0,0,126,0,0,126,0,0,0,0,0,0,0
DATA 0,0,0,0,2,6,12,24,48,96,192,128,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,24,24,0,0,0,0
DATA 0,0,12,24,48,48,48,48,48,48,24,12,0,0,0,0
DATA 0,0,48,24,12,12,12,12,12,12,24,48,0,0,0,0
DATA 0,0,0,0,24,24,0,0,0,24,24,0,0,0,0,0
DATA 0,0,124,198,198,96,56,12,6,198,198,124,0,0,0,0
DATA 0,0,0,0,0,220,102,102,102,102,102,124,96,96,240,0
DATA 0,0,0,0,0,120,12,124,204,204,204,118,0,0,0,0
DATA 0,0,0,0,0,124,198,192,192,192,198,124,0,0,0,0
DATA 0,0,0,0,0,124,198,254,192,192,198,124,0,0,0,0
DATA 0,0,254,102,98,104,120,104,96,98,102,254,0,0,0,0
DATA 0,0,0,0,0,124,198,96,56,12,198,124,0,0,0,0
DATA 0,0,252,102,102,102,124,96,96,96,96,240,0,0,0,0
DATA 0,0,0,0,0,118,204,204,204,204,204,124,12,204,120,0
DATA 0,0,198,198,198,198,198,198,198,198,198,124,0,0,0,0
DATA 0,0,248,108,102,102,102,102,102,102,108,248,0,0,0,0
DATA 0,0,0,0,0,220,102,102,102,102,102,102,0,0,0,0
DATA 0,0,60,102,194,192,192,192,192,194,102,60,0,0,0,0
DATA 0,0,0,0,0,124,198,198,198,198,198,124,0,0,0,0
DATA 0,0,0,0,0,198,198,198,198,198,198,126,6,12,248,0
DATA 0,0,252,102,102,102,124,108,102,102,102,230,0,0,0,0
DATA 0,0,24,24,0,56,24,24,24,24,24,60,0,0,0,0
DATA 0,0,224,96,96,108,118,102,102,102,102,230,0,0,0,0
DATA 0,0,16,48,48,252,48,48,48,48,54,28,0,0,0,0
DATA 0,0,16,56,108,198,198,254,198,198,198,198,0,0,0,0
DATA 0,0,198,198,198,198,198,198,198,108,56,16,0,0,0,0

SUB BlClear
'擦除当前位置的方块
    N% = 1
    FOR Y% = 0 TO CurBl.Hei - 1
        FOR X% = 0 TO CurBl.Wid - 1
            IF MID$(CurBl.Bit, N%, 1) = "1" THEN
               Rx% = (X% + Blx%) * Pexx% + bordx%
               Ry% = (Y% + Bly%) * Pexy% + Bordy%
               LINE (Rx%, Ry%)-(Rx% + 15, Ry% + 15), 0, BF
            END IF
            N% = N% + 1
        NEXT
    NEXT
END SUB

SUB BlDraw
'画当前位置的方块
    N% = 1
    FOR Y% = 0 TO CurBl.Hei - 1
        FOR X% = 0 TO CurBl.Wid - 1
            IF MID$(CurBl.Bit, N%, 1) = "1" THEN
                Ry% = (Bly% + Y%) * Pexx% + Bordy%
                Rx% = (Blx% + X%) * Pexy% + bordx%
                PUT (Rx%, Ry%), BPic, PSET
            END IF
            N% = N% + 1
        NEXT
    NEXT
END SUB

SUB BlGet (e AS BlType)
'随机生成一个方块并随机旋转位置
    RANDOMIZE TIMER
    N% = INT(RND * 11)
    e = Bl(N%)
    N% = INT(RND * 4)
    FOR i% = 1 TO N%: Turn.Left e: NEXT
END SUB

SUB BlInit
    IF NextBl.Wid = 0 THEN
           BlGet NextBl
           BlGet CurBl
        ELSE
           CurBl = NextBl
           BlGet NextBl
    END IF
    '-------------------------
    Blx% = Bgnx%: Bly% = Bgny%
    CALL BlDraw

    LINE (460, 70)-(524, 134), BackClr%, BF
    N% = 1
    FOR Y% = 0 TO NextBl.Hei - 1
        FOR X% = 0 TO NextBl.Wid - 1
            IF MID$(NextBl.Bit, N%, 1) = "1" THEN
                PUT (X% * Pexx% + 461, Y% * Pexy% + 70), BPic, PSET
            END IF
            N% = N% + 1
        NEXT
    NEXT
END SUB

SUB GameOver
    M% = MsgBox("你失败了,按Space继续,Esc退出")
    IF M% THEN
        REDIM Xy(Hei%, Wid%)  AS INTEGER'桶方块数据
        Fast% = 10: NextBl.Wid = 0
        LINE (bordx%, Bordy%)-(bordx% + Wid% * Pexx%, Bordy% + Hei% * Pexy%), 0, BF
        M$ = LTRIM$(RTRIM$(STR$(10 - Fast%)))
        LINE (500, 390)-(520, 407), BackClr%, BF
        MyPrn 501, 391, M$, 13, BackClr%, 0
        MyPrn 500, 390, M$, 4, 0, 0
        Works& = 0
        M$ = LTRIM$(RTRIM$(STR$(Works&)))
        LINE (500, 360)-(550, 377), BackClr%, BF
        MyPrn 501, 361, M$, 13, BackClr%, 0
        MyPrn 500, 360, M$, 4, 0, 0
        Staring% = -1
        CALL BlInit
    ELSE
        END
    END IF
END SUB

SUB Is.CanDown
'判断当前方块是否能够下落,并处理之
    IF Bly% + CurBl.Hei > Hei% - 1 THEN  '已经到达底部
       CALL XYSet
       CALL XYClear
       CALL BlInit
       EXIT SUB
    END IF
    N% = 1
    FOR Y% = 0 TO CurBl.Hei - 1          '看是否能下落
        FOR X% = 0 TO CurBl.Wid - 1
            IF Xy(X% + Blx%, Bly% + Y% + 1) AND MID$(CurBl.Bit, N%, 1) = "1" THEN
                IF Bly% = 0 THEN
                    CALL GameOver
                    EXIT SUB
                END IF
                CALL XYSet
                CALL XYClear
                CALL BlInit
                EXIT SUB
            END IF
            N% = N% + 1
        NEXT
    NEXT
    '能下落,将方块下移一格
    CALL BlClear
    Bly% = Bly% + 1
    CALL BlDraw
END SUB

SUB Is.CanLeft
'判断当前方块是否能够左移
   IF Blx% = 0 THEN EXIT SUB    '己到达最左边
   N% = 1
   FOR Y% = 0 TO CurBl.Hei - 1  '看是否能向左移
       FOR X% = 0 TO CurBl.Wid - 1
           IF Xy(Blx% + X% - 1, Bly% + Y%) AND MID$(CurBl.Bit, N%, 1) = "1" THEN
              EXIT SUB
           END IF
           N% = N% + 1
       NEXT
   NEXT
   '左移一格
   CALL BlClear
   Blx% = Blx% - 1
   CALL BlDraw
END SUB

SUB Is.CanRight
'判断当前方块是否能够右移
   IF Blx% + CurBl.Wid > Wid% - 1 THEN EXIT SUB  '已经到达最右边
   N% = 1
   FOR Y% = 0 TO CurBl.Hei - 1                   '看是否能右移
       FOR X% = 0 TO CurBl.Wid - 1
           IF Xy(Blx% + X% + 1, Bly% + Y%) AND MID$(CurBl.Bit, N%, 1) = "1" THEN
               EXIT SUB
           END IF
           N% = N% + 1
       NEXT
   NEXT
   '方块向右移一格
   CALL BlClear
   Blx% = Blx% + 1
   CALL BlDraw
END SUB

SUB Is.CanTurnLeft
'判断当前方块是否能够向左旋转
    Turn.Left CurBl           '先向左旋转看再说
    '超出边界,无法旋转
    IF CurBl.Hei + Bly% > Hei% THEN : Turn.Right CurBl: EXIT SUB
    IF CurBl.Wid + Blx% > Wid% THEN : Turn.Right CurBl: EXIT SUB
    N% = 1
    FOR Y% = 0 TO CurBl.Hei - 1    '未出边界,看是否能够旋过去
        FOR X% = 0 TO CurBl.Wid - 1
            IF MID$(CurBl.Bit, N%, 1) = "1" AND Xy(Blx% + X%, Bly% + Y) THEN
                Turn.Right CurBl    '旋不过去,转回原来形状
                EXIT SUB
            END IF
            N% = N% + 1
        NEXT
    NEXT
    '可能旋转,将方块旋转并放到最后的位置
    Turn.Right CurBl
    CALL BlClear
    Turn.Left CurBl
    CALL BlDraw
END SUB

SUB Is.CanTurnRight
'判断当前方块是否能够向右旋转
    Turn.Right CurBl          '先向右转了再说
    '超出边界,无法旋转,转回去
    IF CurBl.Hei + Bly% > Hei%  THEN : Turn.Left CurBl: EXIT SUB
    IF CurBl.Wid + Blx% > Wid%  THEN : Turn.Left CurBl: EXIT SUB
    N% = 1
    FOR Y% = 0 TO CurBl.Hei - 1     '未出边界,看是否可能转
        FOR X% = 0 TO CurBl.Wid - 1
            IF MID$(CurBl.Bit, N%, 1) = "1" AND Xy(Blx% + X%, Bly% + Y) THEN
                Turn.Left CurBl      '有方块挡着,转回去
                EXIT SUB
            END IF
            N% = N% + 1
        NEXT
    NEXT
    '可能旋转,旋转后并把方块放到最后位置
    Turn.Left CurBl
    CALL BlClear
    Turn.Right CurBl
    CALL BlDraw
END SUB

FUNCTION MsgBox (stil$)
    N% = LEN(stil$) * 8
    LINE (bordx% + 100, 220)-(bordx% + N% + 116, 244), 14, B
    PAINT (bordx% + 102, 222), 9, 14
    MyPrn bordx% + 108, 224, stil$, 15, 0, 0
    WHILE Quit% = 0
          ikey$ = INKEY$
          IF ikey$ = CHR$(27) THEN EXIT FUNCTION
          IF ikey$ = CHR$(32) THEN MsgBox = -1: EXIT FUNCTION
    WEND
END FUNCTION

SUB MyPrn (X%, Y%, st$, bfclr%, bkclr%, over%)
    CONST Hz$ = "→←↓你失败了按继续退出关卡积分加快减慢下落右移左俄罗斯方块秋风暂停开始旋一"
    CONST Dig$ = "0123456789,=/.():SpaceEsPgUDnCoyRihtAV"
    STATIC Digs() AS INTEGER, Hzs() AS INTEGER
    '76.37
    IF LEN(st$) = 0 THEN EXIT SUB
    Slen% = LEN(st$)
    IF over% <> 0 THEN LINE (X%, Y%)-(X% + Slen% * 8, Y% + 16), bkclr%, BF
    '************************************************************************
    STATIC Lc%
    IF Lc% = 0 THEN
         N% = LEN(Hz$) / 2: M% = LEN(Dig$): Lc% = 1
         REDIM Hzs(N%, 32) AS INTEGER, Digs(M%, 16) AS INTEGER
         FOR i% = 0 TO N% - 1
             FOR J% = 0 TO 31: READ Hzs(i%, J%): NEXT
         NEXT
         FOR i% = 0 TO M% - 1
             FOR J% = 0 TO 15: READ Digs(i%, J%): NEXT
         NEXT
    END IF
    '************************************************************************
    Rx% = X%: N% = 1
    WHILE N% <= Slen%
         B$ = MID$(st$, N%, 1)
         Byte% = ASC(B$)
         IF Byte% < 161 AND Byte% > 32 THEN
              Nober% = INSTR(Dig$, B$) - 1
              FOR i% = 0 TO 15
                     LINE (Rx%, Y% + i%)-(Rx% + 7, Y% + i%), bfclr%, B, Digs(Nober%, i%)
              NEXT
         END IF
         '===================================================================
         IF Byte% >= 161 AND N% <> Slen% THEN
              T$ = MID$(st$, N%, 2)
              Nober% = (INSTR(Hz$, T$) - 1) / 2
              FOR i% = 0 TO 15
                       LINE (Rx%, Y% + i%)-(Rx% + 7, Y% + i%), bfclr%, B, Hzs(Nober%, i% * 2)
                       LINE (Rx% + 8, Y% + i%)-(Rx% + 15, Y% + i%), bfclr%, B, Hzs(Nober%, i% * 2 + 1)
              NEXT
              N% = N% + 1: Rx% = Rx% + 8
         END IF
         N% = N% + 1: Rx% = Rx% + 8
    WEND
END SUB

SUB Set.Palete
'设置调色板
    STATIC rgb() AS INTEGER
    STATIC Lc%
    IF Lc% = 0 THEN
            Lc% = 1
            REDIM rgb(16, 3) AS INTEGER
            OUT &H3C6, 255
            FOR i = 0 TO 15
                OUT &H3C7, i
                rgb(i, 0) = INP(&H3C9)
                rgb(i, 1) = INP(&H3C9)
                rgb(i, 2) = INP(&H3C9)
            NEXT
            Clr# = 63 / 13
            FOR i% = 1 TO 13
                OUT &H3C8, i%
                OUT &H3C9, i% * Clr#
                OUT &H3C9, i% * Clr#
                OUT &H3C9, i% * Clr#
            NEXT
                '-----------------
                OUT &H3C8, 14
                OUT &H3C9, 63
                OUT &H3C9, 0
                OUT &H3C9, 0
                '-----------------
                OUT &H3C8, 15
                OUT &H3C9, 10
                OUT &H3C9, 10
                OUT &H3C9, 63
                '-----------------
                EXIT SUB
    END IF
    OUT &H3C6, 255
    FOR i = 0 TO 15
        OUT &H3C8, i
        OUT &H3C9, rgb(i, 0)
        OUT &H3C9, rgb(i, 1)
        OUT &H3C9, rgb(i, 2)
    NEXT
END SUB

SUB SysInit
'初始化程序
Set.Palete
'-------------------------
'先画一个方块图形保存起来
LINE (0, 0)-(15, 15), 15, B
PAINT (1, 1), 9, 15
FOR i% = 1 TO 13 STEP 3
    Up.Pset i%, 1
    Up.Pset i%, 13
NEXT
FOR i% = 1 TO 13 STEP 3
    Up.Pset 1, i%
    Up.Pset 13, i%
NEXT
GET (0, 0)-(15, 15), BPic
'这是方块的形状,共有11个
'==========================================================================
'             [] []            []   []  []      [][]    []   [][] [][]
'[][][][] [][][] [][][] []   [][][] [][][] [][] [][]  []   [][]     [][]
'(0)      (1)    (2)    (3)  (4)    (5)    (6)  (7)   (8)  (9)    (10)
'==========================================================================
'下面是各个方块形状的数据
Bl(0).Wid = 4: Bl(0).Hei = 1: Bl(0).Bit = "1111"
Bl(1).Wid = 3: Bl(1).Hei = 2: Bl(1).Bit = "001111"
Bl(2).Wid = 3: Bl(2).Hei = 2: Bl(2).Bit = "100111"
Bl(3).Wid = 1: Bl(3).Hei = 1: Bl(3).Bit = "1"
Bl(4).Wid = 3: Bl(4).Hei = 2: Bl(4).Bit = "010111"
Bl(5).Wid = 3: Bl(5).Hei = 2: Bl(5).Bit = "101111"
Bl(6).Wid = 2: Bl(6).Hei = 1: Bl(6).Bit = "11"
Bl(7).Wid = 2: Bl(7).Hei = 2: Bl(7).Bit = "1111"
Bl(8).Wid = 2: Bl(8).Hei = 2: Bl(8).Bit = "0110"
Bl(9).Wid = 3: Bl(9).Hei = 2: Bl(9).Bit = "011110"
Bl(10).Wid = 3: Bl(10).Hei = 2: Bl(10).Bit = "110011"
'==========================================================================
'先画好桶
CLS
FOR i% = 2 TO 6
   LINE (50 - i%, 10 - i%)-(550 + i%, 470 + i%), 11 - i%, B
NEXT
PAINT (100, 100), BackClr%, 9
LINE (bordx% - 1, Bordy% - 1)-(bordx% + 384, Bordy% + 384), 0, BF
FOR i% = 2 TO 6
    LINE (bordx% - i%, Bordy% - 1)-(bordx% - i%, Bordy% + Hei% * Pexy% + i% - 1), i% + 3
    LINE (bordx% + i% + Wid% * Pexx% - 1, Bordy% - 1)-(bordx% + i% + Wid% * Pexx% - 1, Bordy% + Hei% * Pexy% + i% - 1), i% + 3
NEXT
FOR i% = 2 TO 6
    LINE (bordx% - i% + 1, Bordy% + Hei% * Pexy% + i% - 1)-(bordx% + Wid% * Pexx% + i% - 1, Bordy% + Hei% * Pexy% + i% - 1), i% + 3
NEXT
'==========================================================================
'界面
MyPrn 130, 20, "俄罗斯方块 V1.0 秋风 CopyRight(C) 2005.1", 13, 0, 0
MyPrn 129, 19, "俄罗斯方块 V1.0 秋风 CopyRight(C) 2005.1", 4, 0, 0
MyPrn 180, 445, "SPACE 暂停/开始", 13, 0, 0
MyPrn 179, 444, "SPACE 暂停/开始", 0, 0, 0

MyPrn 460, 50, "下一方块", 13, 0, 0
MyPrn 459, 49, "下一方块", 3, 0, 0

MyPrn 461, 151, " A   左旋", 13, 0, 0
MyPrn 460, 150, " A   左旋", 4, 0, 0
MyPrn 461, 181, " S   右旋", 13, 0, 0
MyPrn 460, 180, " S   右旋", 4, 0, 0
MyPrn 461, 211, "←   左移", 13, 0, 0
MyPrn 460, 210, "←   左移", 4, 0, 0
MyPrn 461, 241, "→   右移", 13, 0, 0
MyPrn 460, 240, "→   右移", 4, 0, 0
MyPrn 461, 271, "↓   下落", 13, 0, 0
MyPrn 460, 270, "↓   下落", 4, 0, 0
MyPrn 461, 301, "PgUp 加快", 13, 0, 0
MyPrn 460, 300, "PgUp 加快", 4, 0, 0
MyPrn 461, 331, "PgDn 减慢", 13, 0, 0
MyPrn 460, 330, "PgDn 减慢", 4, 0, 0
MyPrn 461, 361, "积分=0", 13, 0, 0
MyPrn 460, 360, "积分=0", 4, 0, 0
M$ = LTRIM$(RTRIM$(STR$(10 - Fast%)))
MyPrn 461, 391, "关卡=" + M$, 13, 0, 0
MyPrn 460, 390, "关卡=" + M$, 4, 0, 0
END SUB

SUB Turn.Left (e AS BlType)
'将方块向左旋转
DIM T AS STRING * 6
N% = 1
FOR i% = 1 TO e.Hei
    FOR J% = 1 TO e.Wid
        M% = (e.Wid - J%) * e.Hei + i%
        IF MID$(e.Bit, N%, 1) = "1" THEN
              MID$(T$, M%, 1) = "1"
           ELSE
              MID$(T$, M%, 1) = "0"
        END IF
        N% = N% + 1
    NEXT
NEXT
SWAP e.Hei, e.Wid
e.Bit = T$
END SUB

SUB Turn.Right (e AS BlType)
'将方块向右旋转
DIM T AS STRING * 6
N% = 1
FOR i% = 1 TO e.Hei
    FOR J% = 1 TO e.Wid
        M% = J% * e.Hei - i% + 1
        IF MID$(e.Bit, N%, 1) = "1" THEN
              MID$(T$, M%, 1) = "1"
           ELSE
              MID$(T$, M%, 1) = "0"
        END IF
        N% = N% + 1
    NEXT
NEXT
SWAP e.Hei, e.Wid
e.Bit = T$
END SUB

SUB Up.Pset (X%, Y%)
    PSET (X%, Y%), 12
    PSET (X%, Y% + 1), 6
    PSET (X% + 1, Y%), 5
    PSET (X% + 1, Y% + 1), 0
END SUB

SUB XYClear
'判断当前方块填充后是否已满
    FOR Y% = Bly% + CurBl.Hei - 1 TO Bly% STEP -1  '只看当前方块高度
        N% = 0
        FOR X% = 0 TO Wid - 1
            IF Xy(X%, Y%) THEN N% = N% + 1
        NEXT
        IF N% = Wid% THEN    '满了,清除并下移上面的方块
            Works& = Works& + 35
            M$ = LTRIM$(RTRIM$(STR$(Works&)))
            LINE (500, 360)-(550, 377), BackClr%, BF
            MyPrn 501, 361, M$, 13, BackClr%, 0
            MyPrn 500, 360, M$, 4, 0, 0
            IF Works& MOD 700 = 0 THEN
                 Fast% = Fast% - 1
                 M$ = LTRIM$(RTRIM$(STR$(10 - Fast%)))
                 LINE (500, 390)-(520, 407), BackClr%, BF
                 MyPrn 501, 391, M$, 13, BackClr%, 0
                 MyPrn 500, 390, M$, 4, 0, 0
            END IF
            IF Fast% = 0 THEN
            END IF
            FOR i% = Y% TO 1 STEP -1
                FOR J% = 0 TO Wid% - 1
                    Xy(J%, i%) = Xy(J%, i% - 1)
                    Rx% = J% * Pexx% + bordx%
                    Ry% = i% * Pexy% + Bordy%
                    IF Xy(J%, i%) THEN
                          PUT (Rx%, Ry%), BPic, PSET
                       ELSE
                          LINE (Rx%, Ry%)-(Rx% + 15, Ry% + 15), 0, BF
                    END IF
                NEXT
            NEXT
            Y% = Y% + 1
        END IF
    NEXT
END SUB

SUB XYSet
'方块最后停在这个位置,把数据写到数组
    N% = 1
    FOR Y% = 0 TO CurBl.Hei - 1
        FOR X% = 0 TO CurBl.Wid - 1
            IF MID$(CurBl.Bit, N%, 1) = "1" THEN
                Xy(X% + Blx%, Y% + Bly%) = 1
            END IF
            N% = N% + 1
        NEXT
    NEXT
END SUB

板凳

rickone [专家分：15390] 发布于 2005-01-24 14:03:00

8错8错

3 楼

下一个永远 [专家分：0] 发布于 2005-03-19 19:30:00

你真厉害啊!!!!好样的@!!

4 楼

蓝色旋5421 [专家分：0] 发布于 2008-03-01 09:10:00

太不可思议

5 楼

gadenflm [专家分：150] 发布于 2008-11-16 14:42:00

我对QB71佩服的五体投地

[fly]强！！[/fly][em14]

6 楼

gadenflm [专家分：150] 发布于 2009-03-30 19:53:00

我有一个可以保存的，很好玩。
要的可以加 QQ 317627259。

7 楼

gadenflm [专家分：150] 发布于 2009-03-30 19:56:00

DEFINT A-Z

CONST TRUE = 1
CONST FALSE = 0
CONST Interrupt = 1
CONST Normal = 0
CONST Public2Private = 0
CONST Private2Public = 1
CONST High = 20
CONST Wide = 10
CONST perSide = 2
CONST Top = 50
CONST Left = 180
CONST HighPixel = 400
CONST WidePixel = 200
CONST ToUp = 0
CONST ToDown = 2
CONST ToLeft = 1
CONST ToRight = 3
CONST KeyUp = 72
CONST KeyDown = 80
CONST KeyLeft = 75
CONST KeyRight = 77
CONST KeySpace = 32
CONST KeyEnter = 13
CONST KeyESC = 27
CONST KeyBackSpace = 8
CONST KeyTab = 9
CONST KeyANY = -1
CONST KeyNone = 256
CONST ScanEnter = 28            'É¨ÃèÂë
CONST ScanESC = 1
CONST GetNormal = 0             '¶Á¼üÅÌ»º³å·½Ê½
CONST GetLast = 1
CONST FalshDelay = 2000
CONST LineDelay = 8000
CONST MoveDelayTime = 13500
CONST Black = 1
CONST Grey = 0
CONST Bright = 2
CONST Dark = 3
CONST Falsh = 4
CONST Red = 4
CONST Green = 5
CONST Blue = 6
CONST Yellow = 7
CONST Pin = 8
CONST Sky = 9
CONST DeepGreen = 10
CONST DeepRed = 11
CONST TypeHigh = 0
CONST TypeLow = 1
CONST TypeNothing = 2
CONST SaveRecord = 0
CONST SaveHighest = 1
CONST ReadRecord = 2
CONST ReadOther = 3
CONST ReadHighestScore = 4
CONST ReadHighestLevel = 5
CONST DeleteRecord = 6
CONST CreateRecord = 7
CONST FindRecord = 8
CONST Must = 1
CONST WarnSound = 1000
CONST ErrSound = 1200
CONST MaxDiffcult = 30
CONST NewRecord = 1
CONST UnitMax = 7
CONST ToBlack = 1
CONST CloseScreen = 0

TYPE SPRITE
    Names AS STRING * 4
    Left AS INTEGER
    Top AS INTEGER
    w AS INTEGER
    h AS INTEGER
    c AS INTEGER
    Direction AS INTEGER
    Offset AS INTEGER
    sPoint AS INTEGER
END TYPE

TYPE FileRecord
    Names AS STRING * 6
    Score AS INTEGER
    Level AS INTEGER
END TYPE

8 楼

gadenflm [专家分：150] 发布于 2009-03-30 19:57:00

DIM SHARED perLevel AS INTEGER
DIM SHARED perWide  AS INTEGER
DIM SHARED perHigh  AS INTEGER
DIM SHARED Table(High, Wide) AS INTEGER
DIM SHARED MoveDelay(MaxDiffcult) AS INTEGER
DIM SHARED isTrue AS INTEGER
DIM SHARED PicUnit(UnitMax) AS SPRITE
DIM SHARED BasePic(5000) AS INTEGER
DIM SHARED NowUnit AS SPRITE
DIM SHARED NextUnit AS SPRITE
DIM SHARED TempSprite AS SPRITE
DIM SHARED Diffcult AS INTEGER
DIM SHARED TempRecord AS FileRecord
DIM SHARED PublicValue AS INTEGER
DIM SHARED AttribCustom AS INTEGER
DIM SHARED LevelCustom AS INTEGER
DIM SHARED ScoreCustom AS INTEGER
DIM SHARED NameCustom AS STRING * 6
DIM SHARED NameScore AS STRING * 6
DIM SHARED NameLevel AS STRING * 6
DIM SHARED HighestScore AS INTEGER
DIM SHARED HighestLevel AS INTEGER
DIM SHARED TotleRecord AS INTEGER

DECLARE FUNCTION RefurbishTable% ()                             'Return number of clear lines
DECLARE FUNCTION Delay% (DelayTimes AS INTEGER, InterruptKey AS INTEGER) 'Return weather interrupt or not
DECLARE FUNCTION GetKey% (Way AS INTEGER)                       'Return KeyASCcode
DECLARE FUNCTION GetScan% ()                                    'Return KeySCANcode
DECLARE FUNCTION GetX% (From AS INTEGER, Class AS INTEGER)      'Return X changed
DECLARE FUNCTION GetY% (From AS INTEGER, Class AS INTEGER)      'Return Y changed
DECLARE FUNCTION GetSize% (SizeOf AS INTEGER, sWide AS INTEGER, sHigh AS INTEGER)       'Return a Size to save back
DECLARE FUNCTION GetName$ (Leng AS INTEGER, nX AS INTEGER, nY AS INTEGER, nColor AS INTEGER, nCUE AS STRING, nMinAsc AS INTEGER, nMaxAsc AS INTEGER, nType AS INTEGER) 'Return a String
DECLARE FUNCTION Pause% (ContinueKey AS INTEGER)                'Return a KeyASCcode
DECLARE FUNCTION GetMassage% (mLeft AS INTEGER, mTop AS INTEGER, Massage AS STRING, TxColor AS INTEGER, KeyJump AS INTEGER)        'Send a massage
DECLARE FUNCTION isNext% ()                                     'Return weather can go down or left or right
DECLARE FUNCTION isDirect% ()
DECLARE FUNCTION isHighScore% (Score AS INTEGER)                'Return weather the Score is the Highest
DECLARE FUNCTION isHighLevel% (Level AS INTEGER)                'Return weather the Level is the Highest
DECLARE FUNCTION Record% (rType AS INTEGER)                     'Return the answer of Oprating Record
DECLARE FUNCTION Choose% (cX AS INTEGER, cY AS INTEGER, cMassage AS STRING, cColor AS INTEGER)  'Return Y or N
DECLARE FUNCTION ToLand% ()

9 楼

gadenflm [专家分：150] 发布于 2009-03-30 19:58:00

DECLARE SUB Initdata ()
DECLARE SUB RefurbishUnit (rX AS INTEGER, rY AS INTEGER, rColor AS INTEGER)
DECLARE SUB RefurbishRect (rX AS INTEGER, rY AS INTEGER, rColor AS INTEGER)
DECLARE SUB RefurbishLine (rLine AS INTEGER, rColor AS INTEGER)
DECLARE SUB RefurbishScreen ()
DECLARE SUB SPRITEDirectionChange ()
DECLARE SUB ShowSPRITE (UnitInfor AS SPRITE, addX AS INTEGER, addY AS INTEGER)
DECLARE SUB CleanSPRITE (UnitInfor AS SPRITE, addX AS INTEGER, addY AS INTEGER)
DECLARE SUB ShowTable (UnitInfor AS SPRITE, addX AS INTEGER, addY AS INTEGER)
DECLARE SUB DrawBox (bLeft AS INTEGER, bTop AS INTEGER, bWide AS INTEGER, bHigh AS INTEGER, bType AS INTEGER)
DECLARE SUB WarnInfo (WarnRecord AS INTEGER)
DECLARE SUB ErrInfo (ErrRecord AS INTEGER)
DECLARE SUB CurInfo (CurRecord AS INTEGER)
DECLARE SUB DialogBox (DialogRecord AS INTEGER)
DECLARE SUB ShowRecord (RecordNumber AS INTEGER)
DECLARE SUB pEnd (UseWay AS INTEGER)
DECLARE SUB Setup ()
DECLARE SUB Manage ()
DECLARE SUB Control ()
DECLARE SUB InitFace ()
DECLARE SUB Help ()

'Name Wide High Color
DATA "Line","Rect","LefN","RigN","Lef7","Rig7","Soil","NNNN"
DATA 1,2,3,3,2,2,3,2
DATA 4,2,2,2,3,3,2,2
DATA 5,6,7,8,9,10,11,12

DATA 1,1,1,1     ,1,1,1,1     ,1,1,1,1     ,1,1,1,1
DATA 1,1,1,1     ,1,1,1,1     ,1,1,1,1     ,1,1,1,1
DATA 1,1,0,0,1,1 ,0,1,1,1,1,0 ,1,1,0,0,1,1 ,0,1,1,1,1,0
DATA 0,1,1,1,1,0 ,1,0,1,1,0,1 ,0,1,1,1,1,0 ,1,0,1,1,0,1
DATA 1,1,0,1,0,1 ,1,1,1,1,0,0 ,1,0,1,0,1,1 ,0,0,1,1,1,1
DATA 1,1,1,0,1,0 ,1,0,0,1,1,1 ,0,1,0,1,1,1 ,1,1,1,0,0,1
DATA 0,1,0,1,1,1 ,0,1,1,1,0,1 ,1,1,1,0,1,0 ,1,0,1,1,1,0
DATA 1,1,0,1     ,1,1,1,0     ,1,0,1,1     ,0,1,1,1

10 楼

gadenflm [专家分：150] 发布于 2009-03-30 19:58:00

SCREEN 12
DIM Temp AS INTEGER
Diffcult = 0
Initdata
isTrue = TRUE
DO
    FOR i = 0 TO High: FOR j = 0 TO Wide: Table(i, j) = 0: NEXT: NEXT
    IF isTrue = TRUE THEN
        Temp = ToLand
        SELECT CASE Temp
        CASE 1: CALL Setup
        CASE 2: CALL Manage
        CASE 3: CALL pEnd(CloseScreen)
        CASE 4: CALL pEnd(ToBlack)
        CASE 5: CLS : END
        CASE 6: CALL Help
        END SELECT
    END IF
    IF Temp = 0 THEN
        InitFace
        Control
    END IF
LOOP
END
FUNCTION Choose% (cX AS INTEGER, cY AS INTEGER, cMassage AS STRING, cColor AS INTEGER)
    DIM Ret AS STRING * 1
    COLOR cColor: LOCATE cY, cX: PRINT cMassage; "(y/n)?"
    Ret = CHR$(Pause(KeyANY))
    IF Ret = "y" OR Ret = "Y" THEN Choose% = TRUE ELSE Choose% = FALSE
    LOCATE cY, cX: PRINT SPACE$(LEN(cMassage)); "      "
END FUNCTION

您尚未登录，请登录后再回复。点此登录或注册

主题：[原创]俄罗斯方块

回复列表（共15个回复）

我来回复

程序员工具箱 new

代码片段

本版新帖