[原创]：LISP写的俄罗斯方块游戏(源码在七楼)

fools

;; Revision History
;; Rev  By     Date    Description
;;-------------------------------------------------------------------------------
;; 1   FOOLS    2-16-07   农历新年前发布，实现基本功能
;; 2   FOOLS    2-27-07   增加定时增随机行,成绩统计,旋转出界调整

这是一款用autolisp写的俄罗斯方块游戏.加载后键入elsbox执行程序.
模型或图纸空间都可进行游戏,在图纸空间退出时可能会较慢,并非死机.
编写该程序的目的是为了探索通过autolisp模拟编写多线程程序.通过这种方法可以编写其他类似的小游戏,比如坦克大战,挖金子等.
新发布的程序修改版,已经比较接近大家熟悉的俄罗斯方块游戏,通过调整下落速度和随机增加行数可以变换出各种难度.

zml84

[B]fools[/B]兄：附件下不到啊？！
能否发给我一个？ZML84@SOHU.COM
先谢了！

snoopychen

:) 真厉害

虽然Emacs文本编辑器里面也有一个俄罗斯方块，但是它的程序库可要大的多，光靠Vlisp就写出来，高人啊。
xd又开始贴不上图了啊。


[iframe h=500 w=600]http://qjchen.googlepages.com/els.gif[/iframe]

fools

非常感谢snoopychen的友情贴图.
首贴已更新,加了一些说明

fools

多谢关注,邮件已发!
其他下载不了的朋友可到这里下载,
http://www.mjtd.com/BBS/dispbbs. ... ID=58145&page=1

dracula63

附件还真下载不了 痛苦 难道是网速问题

fools

[php]
;;-------------------------------------------------------------------------------
;; Program Name: ElsBox.lsp - [俄罗斯方块 ver2]
;; Created By:   FOOLS (Email: ypy163@163.com)
;; Date Created: 2-16-07
;; Function:     俄罗斯方块
;; Note:         俄罗斯方块游戏
;;-------------------------------------------------------------------------------
;; Revision History
;; Rev  By     Date    Description
;;-------------------------------------------------------------------------------
;; 1   FOOLS    2-16-07   农历新年前发布，实现基本功能
;; 2   FOOLS    2-27-07   增加定时增行,成绩统计,旋转出界调整
;;-------------------------------------------------------------------------------
;; c:ElsBox - 俄罗斯方块
;;-------------------------------------------------------------------------------
(DEFUN c:ElsBox        (/            BOXS       BOXS1          BOXS2             GD                I
                 KEY            LEFTUP     LOOP          NEWBOX     SCORE        BSEED
                 LSEED            LineTime   SIZE          SPEED             DropTime        T0
                 PAUSE            TABLE      TABLES          o_err             UNITAGE        VCEN
                 VH            ZOOMWIN    NEXT1          NEXT2             **SYSVAR**        **SV**
                 Box_AddLine               BOX_cmd0          BOX_cmd1   BOX_err        BOX_VIEWEXTS
                 BOX_RND    BOX_LIMITS BOX_MAKE          BOX_NEW    BOX_MOVE        BOX_ROTATE
                 BOX_SplitList               BOX_Texts  BOX_DROP   BOX_UPDATE
                )
  ;;拟增按键设定对话框  Box_KeyDcl
  ;;写文本
  (DEFUN Box_Texts (pt dist / pt1 height MkTxt)
    ;;生成新文本
    (DEFUN MkTxt (str cen h)
      (ENTMAKEX        (LIST '(0 . "TEXT")
                      '(100 . "AcDbEntity")
                      '(100 . "AcDbText")
                      (CONS 1 str)
                      (CONS 7 "$Box@2007$")
                      (CONS 10 cen)
                      (CONS 72 4)
                      (CONS 11 cen)
                      (CONS 40 h)
                      (CONS 41 0.7)
                )
      )
    )
    ;;MAIN*******************************************************************
    (SETQ height (* 0.08 dist))
    (SETQ pt1 (TRANS (MAPCAR '+ pt (LIST (* 0.6 dist) (* 0.45 dist))) 2 0))
    (MkTxt "俄罗斯方块 2.0" (TRANS pt1 2 0) height)
    (SETQ pt1 (MAPCAR '+ pt (LIST (* 0.15 dist) (* 0.2 dist))))
    (FOREACH item '("NEXT1" "NEXT2")
      (SETQ pt1 (POLAR pt1 0 (* 0.3 dist)))
      (MkTxt item (TRANS pt1 2 0) height)
    )
    (SETQ pt1 (MAPCAR '+ pt (LIST (* -0.6 dist) (* 0.55 dist))))
    (FOREACH item '("游戏操作键"             "按键4<左移一格>"
                    "按键6<右移一格>"             "按键8<逆时针转>"
                    "按键5<快速下落>"             "空格键<顺时针转>"
                    "按键+<增加速度>"             "按键-<降低速度>"
                    "按键P<暂停游戏>"             "按键Q<退出游戏>"
                   )
      (SETQ pt1 (POLAR pt1 (* -0.5 PI) (* 0.1 dist)))
      (MkTxt item (TRANS pt1 2 0) height)
    )
    (SETQ pt1 (MAPCAR '+ pt (LIST (* 0.6 dist) (* -0.45 dist))))
    (MkTxt "Score: 0" (TRANS pt1 2 0) height)
  )
  ;;更新
  (DEFUN Box_Update (ent x y / entlst p10)
    (SETQ entlst (ENTGET ent))
    (SETQ p10 (TRANS (MAPCAR '+ (LIST x y) (TRANS (CDR (ASSOC 10 entlst)) 0 2))
                     2
                     0
              )
    )
    (SETQ entlst (SUBST (CONS 10 p10) (ASSOC 10 entlst) entlst))
    (ENTMOD entlst)
  )
  ;;下降
  (DEFUN Box_Drop (ss          dist         pt        pts    /      CHECK  CHECKS ENTLST I          KEY
                   NLST          NP10         P10        P10LST XLST   YLST   end    y           n          pts1
                   DelLine         ShowScore
                  )
    ;;行满，删除行，并补行
    (DEFUN DelLine (y lst d / ylst entlst i n p10 lst1)
      (FOREACH item (VL-SORT y '>)
        (SETQ ylst (NTH item lst))
        (IF (ZEROP (APPLY '+ (MAPCAR 'CADR ylst)))
          (PROGN (MAPCAR 'ENTDEL (MAPCAR 'LAST ylst))
                 (SETQ lst (VL-REMOVE ylst lst))
                 (ShowScore)
          )
        )
      )
      (IF (/= (LENGTH lst) 20)
        (PROGN (SETQ lst1 (REVERSE (APPLY 'APPEND lst)))
               (SETQ i 240)
               (SETQ lst nil)
               (FOREACH        item lst1
                 (SETQ i (1- i))
                 (IF (= (CAR item) i)
                   (SETQ lst (CONS item lst))
                   (PROGN (SETQ n (/ (- i (CAR item)) 12))
                          (IF (ZEROP (CADR item))
                            (Box_Update (LAST item) 0 (* -1 n d))
                          )
                          (SETQ lst (CONS (CONS i (CDR item)) lst))
                   )
                 )
               )
               (REPEAT i (SETQ lst (CONS (LIST (SETQ i (1- i)) 1) lst)))
               (SETQ lst (BOX_SplitList 12 lst))
        )
      )
      lst
    )
    ;;更新成绩
    (DEFUN ShowScore (/ entlst)
      ;;score全局变量
      (SETQ entlst (ENTGET score))
      (SETQ
        entlst (SUBST (CONS 1
                            (STRCAT "Score: "
                                    (ITOA (1+ (ATOI (SUBSTR (CDR (ASSOC 1 entlst)) 8))))
                            )
                      )
                      (ASSOC 1 entlst)
                      entlst
               )
      )
      (ENTMOD entlst)
    )
    ;;MAIN**********************************************************
    (SETQ key T)
    (SETQ nlst nil)
    (SETQ checks nil)
    (SETQ y nil)
    (FOREACH item ss
      (SETQ p10 (ASSOC 10 (SETQ entlst (ENTGET item))))
      (SETQ np10 (TRANS (POLAR (CDR p10) (* -0.5 PI) dist) 0 2))
      (SETQ nlst (CONS (SUBST (CONS 10 (TRANS np10 2 0)) p10 entlst) nlst))
      (SETQ check (MAPCAR '/ (MAPCAR '- np10 pt) (LIST dist (- dist))))
      (SETQ checks (CONS (LIST check item) checks))
      (IF (AND (> (CADR check) 0)
               (OR (> (CADR check) 20)
                   (ZEROP
                     (CADR (NTH (FIX (CAR check)) (NTH (FIX (CADR check)) pts)))
                   )
               )
          )
        (SETQ key nil)
      )
    )
    (IF        key
      (PROGN (MAPCAR 'ENTMOD nlst) (SETQ pts (LIST nil pts)))
      (PROGN (FOREACH item checks
               (IF (< (CADAR item) 1)
                 (SETQ end T)                ;GameOver
                 (SETQ end  nil
                       y    (CONS (FIX (1- (CADAR item))) y)
                       ylst (NTH (CAR y) pts)
                       xlst (NTH (FIX (CAAR item)) ylst)
                       pts  (SUBST (SUBST (LIST (CAR xlst) 0 (CADR item)) xlst ylst)
                                   ylst
                                   pts
                            )
                 )
               )
             )
             (IF end
               (SETQ pts (LIST "END" pts))
               (SETQ pts (LIST "NEW" (DelLine y pts dist)))
             )
      )
    )
    pts
  )
  ;;旋转
  (DEFUN Box_Rotate (ss        ang dist pt pts        / BOX CEN CHECK        checkx checks ENTLST KEY NLST NP10
                     P10)
    (SETQ key T)
    (SETQ nlst (LIST (ENTGET (CAR ss))))
    (SETQ cen (CDR (ASSOC 10 (CAR nlst))))
    (SETQ checks (LIST (MAPCAR '/
                               (MAPCAR '- (TRANS cen 0 2) pt)
                               (LIST dist (- dist))
                       )
                 )
    )
    (FOREACH item (CDR ss)
      (SETQ p10 (CDR (ASSOC 10 (SETQ entlst (ENTGET item)))))
      (SETQ np10 (TRANS        (POLAR cen
                               (+ (* ang PI) (ANGLE cen p10))
                               (DISTANCE cen p10)
                        )
                        0
                        2
                 )
      )
      (SETQ nlst (CONS (SUBST (CONS 10 (TRANS np10 2 0)) (CONS 10 p10) entlst)
                       nlst
                 )
      )
      (SETQ check (MAPCAR '/ (MAPCAR '- np10 pt) (LIST dist (- dist))))
      (SETQ checks (CONS check checks))
    )
    (IF        (> (APPLY 'MIN (MAPCAR 'CADR checks)) 0)
      (PROGN (SETQ checkx (VL-SORT (MAPCAR 'CAR checks) '<))
             (IF (MINUSP (CAR checkx))
               (SETQ checkx (- (CAR checkx) 0.5))
               (IF (> (LAST checkx) 12)
                 (SETQ checkx (- (LAST checkx) 11.5))
                 (SETQ checkx nil)
               )
             )
             (IF checkx
               (SETQ nlst   (MAPCAR (FUNCTION
                                      (LAMBDA (x)
                                        (SUBST (MAPCAR '- (ASSOC 10 x) (LIST 0 (* checkx dist) 0))
                                               (ASSOC 10 x)
                                               x
                                        )
                                      )
                                    )
                                    nlst
                            )
                     checks (MAPCAR (FUNCTION (LAMBDA (x) (LIST (- (CAR x) checkx) (CADR x))))
                                    checks
                            )
               )
             )
             (FOREACH item checks
               (IF (OR (> (CADR item) 20)
                       (ZEROP
                         (CADR (NTH (FIX (CAR item)) (NTH (FIX (CADR item)) pts)))
                       )
                   )
                 (SETQ key nil)
               )
             )
             (IF key
               (MAPCAR 'ENTMOD nlst)
             )
      )
    )
  )
  ;;平移
  (DEFUN Box_Move (ss ang dist pt pts / check key nlst np10 p10 entlst box)
    (SETQ key T)
    (SETQ nlst nil)
    (WHILE (AND key ss)
      (SETQ box (CAR ss))
      (SETQ ss (CDR ss))
      (SETQ p10 (ASSOC 10 (SETQ entlst (ENTGET box))))
      (SETQ np10 (TRANS (POLAR (CDR p10) ang dist) 0 2))
      (SETQ nlst (CONS (SUBST (CONS 10 (TRANS np10 2 0)) p10 entlst) nlst))
      (SETQ check (MAPCAR '/ (MAPCAR '- np10 pt) (LIST dist (- dist))))
      (IF (AND (> (CADR check) 0)
               (OR (MINUSP (CAR check))
                   (> (CAR check) 12)
                   (ZEROP
                     (CADR (NTH (FIX (CAR check)) (NTH (FIX (CADR check)) pts)))
                   )
               )
          )
        (SETQ key nil)
      )
    )
    (IF        key
      (MAPCAR 'ENTMOD nlst)
    )
  )
  ;;读取方块信息
  (DEFUN Box_New (num pt dist / boxs lst)
    ;;  以下是七种方块形状数据,这七块的形状是:
    ;;  (1)   (2)    (3)    (4)    (5)   (6)    (7)
    ;;  []    []      []   [][]     []   []     []
    ;;  []    []      []   [][]   [][]   [][]   [][]
    ;;  []    [][]  [][]          []       []   []
    ;;  []
    (SETQ boxs (NTH num
                    '(((-1 0) (1 0) (2 0) (0 0))
                      ((1 0) (0 0) (0 2) (0 1))
                      ((0 0) (1 0) (1 2) (1 1))
                      ((0 0) (1 0) (1 1) (0 1))
                      ((0 0) (1 1) (1 2) (0 1))
                      ((1 0) (0 1) (0 2) (1 1))
                      ((0 0) (1 1) (0 2) (0 1))
                     )
               )
    )
    (SETQ lst nil)
    (FOREACH item boxs
      ;;插入图块
      (ENTMAKEX
        (LIST '(0 . "INSERT")
              '(100 . "AcDbEntity")
              '(100 . "AcDbBlockReference")
              (CONS 2 "$Box@2007$")
              (CONS 10 (MAPCAR '+ pt (MAPCAR '* item (LIST dist dist))))
              (CONS 41 (* 0.88 dist))
              (CONS 42 (* 0.88 dist))
              (CONS 62 (1+ num))
        )
      )
      (SETQ lst (CONS (ENTLAST) lst))
    )
    lst
  )
  ;;生成块和字型
  (DEFUN Box_Make ()
    (IF        (NOT (TBLSEARCH "STYLE" "$Box@2007$"))
      (ENTMAKEX        (LIST '(0 . "STYLE")                 '(100 . "AcDbSymbolTableRecord")
                      '(100 . "AcDbTextStyleTableRecord")
                      '(2 . "$Box@2007$")         '(70 . 0)
                      '(40 . 0.0)                 '(41 . 0.7)
                      '(50 . 0.0)                 '(71 . 0)
                      '(42 . 300.)                 '(3 . "ROMANS")
                      '(4 . "HZTXT")
                     )
      )
    )
    (IF        (NOT (TBLSEARCH "BLOCK" "$Box@2007$"))
      (PROGN ;;做块头
             (ENTMAKEX (LIST '(0 . "BLOCK")               '(100 . "AcDbEntity")
                             '(100 . "AcDbBlockBegin") '(2 . "$Box@2007$")
                             '(70 . 2)                       '(10 0. 0.)
                            )
             )
             ;;色块
             (ENTMAKEX (LIST '(0 . "SOLID")            '(100 . "AcDbEntity")
                             '(100 . "AcDbTrace")   '(62 . 0)
                             '(10 -0.5 -0.5)            '(11 -0.5 0.5)
                             '(12 0.5 -0.5)            '(13 0.5 0.5)
                            )
             )
             ;;线框
             (ENTMAKEX (LIST '(0 . "LWPOLYLINE")    '(100 . "AcDbEntity")
                             '(100 . "AcDbPolyline")
                             '(6 . "Continuous")    '(62 . 252)
                             '(43 . 0.03)            '(38 . 0.0)
                             '(39 . 0.0)            '(90 . 4)
                             '(70 . 1)                    '(10 -0.5 -0.5)
                             '(10 -0.5 0.5)            '(10 0.5 0.5)
                             '(10 0.5 -0.5)
                            )
             )
             (ENTMAKEX (LIST '(0 . "LWPOLYLINE")    '(100 . "AcDbEntity")
                             '(100 . "AcDbPolyline")
                             '(6 . "Continuous")    '(62 . 252)
                             '(43 . 0.03)            '(38 . 0.0)
                             '(39 . 0.0)            '(90 . 4)
                             '(70 . 1)                    '(10 -0.25 -0.25)
                             '(10 -0.25 0.25)            '(10 0.25 0.25)
                             '(10 0.25 -0.25)
                            )
             )
             (ENTMAKEX (LIST '(0 . "LWPOLYLINE")     '(100 . "AcDbEntity")
                             '(100 . "AcDbPolyline") '(6 . "Continuous")
                             '(62 . 252)             '(43 . 0.03)
                             '(38 . 0.0)             '(39 . 0.0)
                             '(90 . 2)                     '(10 -0.5 -0.5)
                             '(10 -0.25 -0.25)
                            )
             )
             (ENTMAKEX (LIST '(0 . "LWPOLYLINE")    '(100 . "AcDbEntity")
                             '(100 . "AcDbPolyline")
                             '(6 . "Continuous")    '(62 . 252)
                             '(43 . 0.03)            '(38 . 0.0)
                             '(39 . 0.0)            '(90 . 2)
                             '(10 0.5 0.5)            '(10 0.25 0.25)
                            )
             )
             (ENTMAKEX (LIST '(0 . "LWPOLYLINE")     '(100 . "AcDbEntity")
                             '(100 . "AcDbPolyline") '(6 . "Continuous")
                             '(62 . 252)             '(43 . 0.03)
                             '(38 . 0.0)             '(39 . 0.0)
                             '(90 . 2)                     '(10 -0.5 0.5)
                             '(10 -0.25 0.25)
                            )
             )
             (ENTMAKEX (LIST '(0 . "LWPOLYLINE")     '(100 . "AcDbEntity")
                             '(100 . "AcDbPolyline") '(6 . "Continuous")
                             '(62 . 252)             '(43 . 0.03)
                             '(38 . 0.0)             '(39 . 0.0)
                             '(90 . 2)                     '(10 0.5 -0.5)
                             '(10 0.25 -0.25)
                            )
             )
             ;;做块尾
             (ENTMAKEX (LIST '(0 . "ENDBLK")
                             '(100 . "AcDbEntity")
                             '(100 . "AcDbBlockEnd")
                       )
             )
      )
    )
  )
  ;;游戏区域
  (DEFUN Box_Limits (ViewH Cen / Half leftup rightlow)
    (SETQ Half (LIST (* 0.3 ViewH) (* -0.5 ViewH))) ;20x12
    (SETQ leftup (TRANS (MAPCAR '- Cen Half) 2 1))
    (SETQ rightlow (TRANS (MAPCAR '+ Cen Half) 2 1))
    (COMMAND "_RECTANG" leftup rightlow)
    (TRANS leftup 1 2)
  )
  ;;生成随机数
  (DEFUN Box_Rnd (seed nmin nmax / test)
    (IF        (NOT seed)
      (SETQ seed (ATOI (SUBSTR (RTOS (GETVAR "cputicks")) 7)))
      (SETQ seed (CADR seed))
    )
    (SETQ test (- (* 48271 (REM seed 44488)) (* 3399 (/ seed 44488))))
    (IF        (>= test 0)
      (SETQ seed test)
      (SETQ seed (+ test 2147483647))
    )
    (LIST (FIX (+ nmin (/ (* (- nmax nmin) (FLOAT seed)) 2147483647)))
          seed
    )
  )
  ;;等分表
  (DEFUN BOX_SplitList (n lst / ret out cnt)
    (SETQ ret nil)                        ; possible VL lsa compiler bug
    ;; adjust cnt to set incomplete number of elements (if any) for the
    ;; last segment
    (SETQ cnt (- n (REM (LENGTH lst) n))
          lst (REVERSE lst)
    )
    (WHILE lst
      (SETQ ret        (CONS (CAR lst) ret)
            lst        (CDR lst)
      )
      (IF (ZEROP (REM (SETQ cnt (1+ cnt)) n))
        (SETQ out (CONS ret out)
              ret nil
        )
      )
    )
    (IF        ret
      (CONS ret out)
      out
    )
  )
  ;;增加一随机行
  (DEFUN Box_AddLine (num dist pt pts / lst boxs i color)
    (IF        (< (APPLY '+ (MAPCAR 'CADR (CAR pts))) 8)
      (SETQ pts (LIST "END" pts))        ;Game Over
      (PROGN (SETQ boxs nil)
             (SETQ color (REM num 7))
             (WHILE (> num 0)
               (SETQ boxs (CONS (REM num 2) boxs)
                     num  (LSH num -1)
               )
             )
             (SETQ i 11)
             (SETQ lst nil)
             (SETQ pt (TRANS (MAPCAR '+ pt (LIST (* 0.5 dist) (* -19.5 dist)))
                             2
                             0
                      )
             )
             (FOREACH item boxs
               (IF (ZEROP item)
                 (PROGN        ;;插入图块
                        (ENTMAKEX (LIST        '(0 . "INSERT")
                                        '(100 . "AcDbEntity")
                                        '(100 . "AcDbBlockReference")
                                        (CONS 2 "$Box@2007$")
                                        (CONS 10 (MAPCAR '+ pt (LIST (* i dist) 0)))
                                        (CONS 41 (* 0.88 dist))
                                        (CONS 42 (* 0.88 dist))
                                        (CONS 62 (CAR (Box_Rnd nil 1 8)))
                                  )
                        )
                        (SETQ lst (CONS (LIST (+ 228 i) item (ENTLAST)) lst))
                 )
                 (SETQ lst (CONS (LIST (+ 228 i) item) lst))
               )
               (SETQ i (1- i))
             )
             (FOREACH item (REVERSE (APPLY 'APPEND (CDR pts)))
               (IF (ZEROP (CADR item))
                 (Box_Update (LAST item) 0 dist)
               )
               (SETQ lst (CONS (CONS (- (CAR item) 12) (CDR item)) lst))
             )
             (SETQ pts (BOX_SplitList 12 lst))
      )
    )
  )
  ;;显示区域
  ;;-------------------------------------------------------------------------------
  ;; ViewExtents
  ;; Returns: List of lower left and upper right points of current view
  ;;-------------------------------------------------------------------------------
  (DEFUN Box_ViewExts (Pixels ViewH Cen / Half)
    (SETQ Half (LIST (* 0.5 ViewH (APPLY '/ Pixels)) (* 0.5 ViewH)))
    (LIST (TRANS (MAPCAR '- Cen Half) 2 1) ; lower left
          (TRANS (MAPCAR '+ Cen Half) 2 1) ; upper right
    )
  )
  ;;************************************************************
  ;;程序初始/结尾处理/错误处理函数
  (DEFUN BOX_cmd0 ()
    (SETQ **SYSVAR**
           '("AUNITS"           "AUPREC"         "ATTDIA"      "BLIPMODE"    "CECOLOR"
             "CELTYPE"           "CLAYER"         "CMDECHO"     "DIMADEC"     "DIMDEC"
             "DIMZIN"           "EXPERT"         "HIGHLIGHT"   "LUNITS"             "LUPREC"
             "OSMODE"           "ORTHOMODE"         "PICKBOX"     "PLINEWID"    "QAFLAGS"
             "REGENMODE"   "TEXTSTYLE"         "CURSORSIZE"
            )
    )
    (SETQ **SV** '())
    (FOREACH sv        **SYSVAR**
      (SETQ **SV** (CONS (GETVAR sv) **SV**))
    )
    (FOREACH sv        '("ATTDIA"         "BLIPMODE"        "CMDECHO"      "DIMZIN"
                  "ORTHOMODE"         "OSMODE"        "PICKBOX"      "PLINEWID"
                  "REGENMODE"
                 )
      (SETVAR sv 0)
    )
    (SETVAR "QAFLAGS" 1)
    (SETVAR "CURSORSIZE" 1)
    (SETQ o_err          *ERROR*
          *ERROR* BOX_err
    )
    (COMMAND "_.UNDO" "_BE")
    (PRINC)
  )
  (DEFUN BOX_cmd1 ()
    (COMMAND "_.UNDO" "_E")
    (COMMAND "_.UNDO" 1)
    (COMMAND "_.REDRAW")
    (MAPCAR 'SETVAR **SYSVAR** (REVERSE **SV**))
    (SETQ *ERROR* o_err)
  )
  (DEFUN BOX_err (msg)                        ;变量msg保存着错误信息             
    (IF        (/= msg "Function cancelled")
      (IF (= msg "quit / exit abort")
        (PRINC)
        (PRINC (STRCAT "\n错误: " msg))
      )
      (PRINC)
    )
    (BOX_cmd1)
    (PRINC)
  )
  ;;MAIN************************************************************
  (BOX_cmd0)
  (SETQ vh (GETVAR "VIEWSIZE"))
  (SETQ size (GETVAR "SCREENSIZE"))
  (SETQ vcen (TRANS (GETVAR "VIEWCTR") 1 2))
  (SETQ next2 (MAPCAR '+ (LIST (* 0.75 vh) 0) vcen))
  (SETQ next1 (MAPCAR '+ (LIST (* 0.45 vh) 0) vcen))
  (SETQ speed 650)
  (SETQ ZoomWin (Box_ViewExts size vh vcen))
  (SETQ LeftUp (Box_Limits vh vcen))
  (SETQ Unitage (/ vh 20.))
  ;;建块
  (Box_Make)
  (SETQ score (Box_Texts vcen vh))
  ;;生成方位表格
  (SETQ Tables nil)
  (SETQ i 240)
  (REPEAT 20
    (SETQ Table nil)
    (REPEAT 12
      (SETQ Table (CONS (LIST (SETQ i (1- i)) 1) Table))
    )
    (SETQ Tables (CONS Table Tables))
  )
  ;;随机函数初始化
  (SETQ bseed nil)
  (SETQ lseed nil)
  (SETQ        bseed  (Box_Rnd bseed 0 7)
        Boxs1  (Box_New (CAR bseed) next1 Unitage)
        bseed  (Box_Rnd bseed 0 7)
        Boxs2  (Box_New (CAR bseed) next2 Unitage)
        newbox T
  )
  (SETQ loop T)
  (SETQ pause T)
  (PRINC "\n\t*****按  任  意  键  开  始  游  戏 *****\n")
  (SETQ DropTime (* 8.64E7 (GETVAR "tdusrtimer"))) ;毫秒
  (SETQ LineTime DropTime)
  (WHILE loop
    (IF        newbox
      (PROGN (SETQ Boxs          Boxs1
                   Boxs1  Boxs2
                   bseed  (Box_Rnd bseed 0 7)
                   Boxs2  (Box_New (CAR bseed) next2 Unitage)
                   newbox nil
             )
             (FOREACH item Boxs
               (Box_Update item (* -0.475 vh) (* 0.525 vh))
             )
             (FOREACH item Boxs1 (Box_Update item (* -0.3 vh) 0))
      )
    )
    ;;延时speed毫秒并返回所按键的ASCII码
    (GRREAD (SETQ gd (GRREAD T 15 1)))
    (IF        (OR (EQUAL gd '(2 112)) (EQUAL gd '(2 80)))
      (SETQ pause (NOT pause))
    )
    (IF        pause
      (PROGN (IF (AND (= (CAR gd) 2)
                      (SETQ key (MEMBER (CADR gd) '(32 43 45 52 53 54 56 81 113)))
                      (SETQ key (STRCASE (CHR (CAR key))))
                 )
               (COND ((= key "8") (Box_Rotate Boxs 0.5 Unitage LeftUp Tables))
                     ((= key "5")
                      (SETQ Tables (Box_Drop Boxs Unitage LeftUp Tables))
                      (WHILE (NOT (CAR tables))
                        (SETQ Tables (Box_Drop Boxs Unitage LeftUp (CADR Tables)))
                      )
                      (IF (= (CAR tables) "END")
                        (SETQ loop nil)
                        (SETQ tables (CADR tables)
                              newbox T
                        )
                      )
                     )
                     ((= key "4") (Box_Move Boxs PI Unitage LeftUp Tables))
                     ((= key "6") (Box_Move Boxs 0 Unitage LeftUp Tables))
                     ((= key " ") (Box_Rotate Boxs -0.5 Unitage LeftUp Tables))
                     ((= key "-")
                      (IF (<= speed 1250)
                        (SETQ speed (+ speed 200))
                      )
                     )
                     ((= key "+")
                      (IF (>= speed 250)
                        (SETQ speed (- speed 200))
                      )
                     )
                     ((= key "Q") (SETQ loop nil))
               )
             )
             (SETQ T0 (* 8.64E7 (GETVAR "tdusrtimer")))
             ;;增加一行间隔时间
             (IF (> (- T0 LineTime) (* 100 speed))
               (PROGN (SETQ LineTime T0)
                      (SETQ lseed (Box_Rnd lseed 2048 4094))
                      (SETQ Tables (Box_AddLine (CAR lseed) Unitage LeftUp Tables))
                      (IF (= (CAR Tables) "END")
                        (SETQ loop nil)
                      )
               )
             )
             ;;下落间隔时间
             (IF (AND (> (- T0 DropTime) speed) (NOT newbox))
               (PROGN (SETQ DropTime T0)
                      (SETQ Tables (Box_Drop Boxs Unitage LeftUp Tables))
                      (COND ((= (CAR tables) "NEW") (SETQ newbox T))
                            ((= (CAR tables) "END") (SETQ loop nil))
                      )
                      (SETQ tables (CADR tables))
               )
             )
      )
    )
    (COMMAND "_.ZOOM" "_W" (CAR ZoomWin) (CADR ZoomWin))
  )   
  (BOX_cmd1)
  (PRINC)
)

(PRINC "\n程序加载成功，键入ELSBOX运行俄罗斯方块游戏！")
(PRINC)
[/php]

黄河之水

真是高人呀

diskcopy

我想下载阿，可惜爱心币不够啊

haibinpro

最初由 diskcopy 发布
[B]我想下载阿，可惜爱心币不够啊 [/B]

兄弟，灌水不是这样灌的。
btw，程序执行效率有点慢。运行起来不太流畅（体现在切换旋转角度时。）。

bluice

真的很佩服你，不过怎么下不了呢

flowerson

真是我的偶像。我也在努力学习中。

asdf_021128

好厉害啊，可是我加载的时候怎么提示错误，但是按ESC键后，可以看到楼上显示的图片中的文字

turner407

这个程序要顶的，是比较厉害。

egos

碰到一个奇怪的问题 在有些CAD文件中可以正常加载，在某些CAD文件中却不能运行！不知何解？