CyberChaos(さいばかおす)

プログラミング言語、トランスパイラ、RPA、ChatGPT、データマイニング、リバースエンジニアリングのための忘備録

Autocadでテトリス!AutoLisp言語でテトリス!

2023-11-04 21:22:24 | Autocad

Tetris for AutoCAD - help with grread

Tetris for AutoCAD - help with grread

I thought it might be interesting to play a quick game inside AutoCAD, so yesterday i wrote a quick draft for a tetris game. The idea was to store the game info...

Autodesk Community

(defun c:tetris ( / ) ;;----------------------=={ Remove Nth }==--------------------;; ;; ;; ;; Removes the item at the nth index in a supplied list ;; ;;------------------------------------------------------------;; ;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; n - index of item to remove (zero based) ;; ;; l - list from which item is to be removed ;; ;;------------------------------------------------------------;; ;; Returns: List with item at index n removed ;; ;;------------------------------------------------------------;; (defun LM:RemoveNth ( n l / i ) (setq i -1) (vl-remove-if '(lambda ( x ) (= (setq i (1+ i)) n)) l) );defun (defun CreateCanvas () (setq canvasEnt (LWPoly (list origin (mapcar '+ origin (list 0 (* rows pixelSize) 0)) (mapcar '+ origin (list (* cols pixelSize) (* rows pixelSize) 0)) (mapcar '+ origin (list (* cols pixelSize) 0 0)))) ) (ClearCanvas rows cols) );defun (defun ClearCanvas (rows cols) (setq canvas nil) (repeat rows (setq canvas (cons (repeat cols (EmptyRow)) canvas))) );defun (defun EmptyRow ( / row) (repeat cols (setq row (cons 0 row))) );defun (defun RemoveRow (rowPos / row) (setq canvas (append (LM:RemoveNth rowPos canvas) (list (EmptyRow)))) );defun (defun LWPoly (lst) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 1)) (mapcar (function (lambda (p) (cons 10 p))) lst))) );defun (defun NewPixel (pt) (setq activeShapePos (cons (mapcar '/ pt (list 10 10)) activeShapePos)) (LWPoly (list pt (mapcar '+ pt (list 0 pixelSize 0)) (mapcar '+ pt (list pixelSize pixelSize 0)) (mapcar '+ pt (list pixelSize 0 0)))) );defun (defun Shape1 () (setq activeShapePos nil) (mapcar '(lambda (pixel) (ssadd pixel activeShape) ) (list (NewPixel spawnPoint) (NewPixel (mapcar '+ spawnPoint (list 0 pixelSize 0))) (NewPixel (mapcar '+ spawnPoint (list pixelSize pixelSize 0))) (NewPixel (mapcar '+ spawnPoint (list pixelSize 0 0))) ) ) );defun (defun SpawnShape (shape) (setq activeShape (ssadd)) (cond ((= shape 1) (Shape1)) );cond );defun ;;;(defun ShapeStop (shape) ;;; ;;;);defun ;;; ;;;(defun ShapeRotate (shape) ;;; ;;;);defun (defun MoveUp () (command "move" activeShape "" (list 0 0 0) (list 0 pixelSize 0)) );defun (defun MoveDown () (command "move" activeShape "" (list 0 0 0) (list 0 (* pixelSize -1) 0)) );defun (defun MoveLeft () (command "move" activeShape "" (list 0 0 0) (list (* pixelSize -1) 0 0)) );defun (defun MoveRight () (command "move" activeShape "" (list 0 0 0) (list pixelSize 0 0)) );defun (defun sleep (secs / time) (setq time (getvar "Millisecs")) (while (< (/ (- (getvar "Millisecs") time) 1000.0) secs) nil) );defun ;;; ;;; FUNCTION STARTS HERE ;;; (setq origin (list 0 0 0)) (setq pixelSize 10) (setq rows 20) (setq cols 10) (setq spawnPoint (mapcar '+ origin (list (* (- (/ cols 2) 1) pixelSize) (* rows pixelSize) 0))) ;;;(setq canvasX (* pixelSize cols)) ;;;(setq canvasY (* pixelSize rows)) ;;;(setq color 7) ;;;(setq activeShapeColor 3) (setq gameOver nil) (setq timer nil) (setq tick 0.5) (command "_-view" "_t") (command "_ucs" "_w") (CreateCanvas) (command "_zoom" "o" canvasEnt "") (SpawnShape 1) (while (not gameOver) (if (not timer) (setq timer (getvar "Millisecs"))) (if (< (/ (- (getvar "Millisecs") timer) 1000.0) tick) (progn (setq gRead (grread T 15 1) grCode (car gRead) grVal (cadr gRead)) (cond ;Quit game ((vl-position grVal '(113 81)) (setq gameOver T) (alert "Game Over!"));q Q ((vl-position grVal '(115 83)) (MoveDown));s S ((vl-position grVal '(97 65)) (MoveLeft));a A ((vl-position grVal '(100 68)) (MoveRight));d D ((vl-position grVal '(119 87)) (MoveUp));w W for testing );cond ) (progn (MoveDown) (setq timer (getvar "Millisecs")) ) ) );main loop (princ) );defun