
;; TetrisSquareクラスの定義
(defun TetrisSquare (x y color)
(list x y color))
(defun TetrisSquareGetX (square)
(nth 0 square))
(defun TetrisSquareGetY (square)
(nth 1 square))
(defun TetrisSquareGetColor (square)
(nth 2 square))
;; TetrisFieldクラスの定義
(defun TetrisField (/ width height squares)
(setq width 10
height 20
squares (make-array (list height width))))
(defun TetrisFieldGetWidth ()
width)
(defun TetrisFieldGetHeight ()
height)
(defun TetrisFieldGetSquare (x y)
(aref squares y x))
(defun TetrisFieldJudgeGameOver (block)
(setq noEmptyCord (list)
blockCord (list))
(repeat height
(repeat width
(if (/= "gray" (TetrisSquareGetColor (TetrisFieldGetSquare x y)))
(setq noEmptyCord (cons (cons x y) noEmptyCord)))
(setq x (+ x 1))
)
(setq x 0
y (+ y 1))
)
(foreach square (TetrisBlockGetSquares block)
(setq cord (TetrisSquareGetCord square))
(setq blockCord (cons (cons (car cord) (cadr cord)) blockCord))
)
(setq blockCord (vl-remove-if-not '(lambda (x) (member x noEmptyCord)) blockCord))
(> (length blockCord) 0)
)
(defun TetrisFieldJudgeCanMove (block direction)
(setq noEmptyCord (list))
(repeat height
(repeat width
(if (/= "gray" (TetrisSquareGetColor (TetrisFieldGetSquare x y)))
(setq noEmptyCord (cons (cons x y) noEmptyCord)))
(setq x (+ x 1))
)
(setq x 0
y (+ y 1))
)
(setq moveBlockCord (list))
(foreach square (TetrisBlockGetSquares block)
(setq cord (TetrisSquareGetMovedCord square direction))
(setq moveBlockCord (cons (cons (car cord) (cadr cord)) moveBlockCord))
(if (or (< (car cord) 0)
(>= (car cord) width)
(< (cadr cord) 0)
(>= (cadr cord) height))
(return nil)
)
)
(setq moveBlockCord (vl-remove-if-not '(lambda (x) (member x noEmptyCord)) moveBlockCord))
(= (length moveBlockCord) 0)
)
(defun TetrisFieldFixBlock (block)
(foreach square (TetrisBlockGetSquares block)
(setq x (car (TetrisSquareGetCord square))
y (cadr (TetrisSquareGetCord square))
color (TetrisSquareGetColor square))
(setq (nth y (nth x squares)) (TetrisSquare x y color))
)
)
(defun TetrisFieldDeleteLine ()
(setq y (- height 1))
(while (>= y 0)
(setq isFull T)
(setq x 0)
(while (< x width)
(if (= "gray" (TetrisSquareGetColor (TetrisFieldGetSquare x y)))
(setq isFull nil))
(setq x (+ x 1))
)
(if isFull
(progn
(setq yy y)
(while (> yy 0)
(setq x 0)
(while (< x width)
(setq (nth yy (nth x squares)) (TetrisSquareGetX (nth (- yy 1) (nth x squares)))
(TetrisSquareGetY (nth (- yy 1) (nth x squares)))
(TetrisSquareGetColor (nth (- yy 1) (nth x squares)))))
(setq x (+ x 1))
)
(setq yy (- yy 1))
)
(setq x 0)
(while (< x width)
(setq (nth 0 (nth x squares)) (TetrisSquare x 0 "gray"))
(setq x (+ x 1))
)
(setq y (+ y 1))
)
)
(setq y (- y 1))
)
)
;; TetrisBlockクラスの定義
(defun TetrisBlock (/ squares)
(setq squares (list))
(setq blockType (random 4))
(cond
((= blockType 0)
(setq color "red"
cords (list (list (/ 10 2) 0)
(list (/ 10 2) 1)
(list (/ 10 2) 2)
(list (/ 10 2) 3))))
((= blockType 1)
(setq color "blue"
cords (list (list (/ 10 2) 0)
(list (/ 10 2) 1)
(list (- (/ 10 2) 1) 0)
(list (- (/ 10 2) 1) 1))))
((= blockType 2)
(setq color "green"
cords (list (list (- (/ 10 2) 1) 0)
(list (/ 10 2) 0)
(list (/ 10 2) 1)
(list (/ 10 2) 2))))
((= blockType 3)
(setq color "orange"
cords (list (list (/ 10 2) 0)
(list (- (/ 10 2) 1) 0)
(list (- (/ 10 2) 1) 1)
(list (- (/ 10 2) 1) 2))))
(T
(setq color "gray"
cords nil))
)
(foreach cord cords
(setq squares (cons (TetrisSquare (car cord) (cadr cord) color) squares))
)
squares
)
(defun TetrisBlockGetSquares (block)
squares)
(defun TetrisBlockMove (block direction)
(setq newSquares (list))
(foreach square squares
(setq movedCord (TetrisSquareGetMovedCord square direction)
x (car movedCord)
y (cadr movedCord))
(setq newSquares (cons (TetrisSquare x y (TetrisSquareGetColor square)) newSquares))
)
(setq squares newSquares)
)
;; TetrisGameクラスの定義
(defun TetrisGame (/ field block canvas)
(setq field (TetrisField)
block nil
canvas nil))
(defun TetrisGameStart ()
(setq field (TetrisField)
block nil
canvas (TetrisCanvas field))
)
(defun TetrisGameNewBlock ()
(setq block (TetrisBlock))
(if (TetrisFieldJudgeGameOver block)
(progn
(princ "GAMEOVER")
(terpri))
)
)
(defun TetrisGameMoveBlock (direction)
(if (TetrisFieldJudgeCanMove block direction)
(progn
(TetrisBlockMove block direction)
(TetrisCanvasUpdate canvas field block))
(if (= direction 2)
(progn
(TetrisFieldFixBlock block)
(TetrisFieldDeleteLine)
(TetrisGameNewBlock)
(TetrisCanvasUpdate canvas field block))
)
)
)
;; TetrisCanvasクラスの定義
(defun TetrisCanvas (field)
(setq beforeField field
field field))
(defun TetrisCanvasUpdate (field block)
(setq beforeField field)
;; キャンバスを更新する処理
)
;; TetrisCommandsクラスの定義
(defun c:TETRIS ()
(setq field (TetrisField)
block nil
canvas (TetrisCanvas field)
game (TetrisGame))
(TetrisGameStart)
(while T
;; ユーザー入力を取得し、適切な方向で game.MoveBlock(direction) を呼び出す
)
)
さてどうなるか?
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Public Class MyCommands
<CommandMethod("bot")>
Public Sub ProcessUserInput()
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim ed As Editor = doc.Editor
Dim userInput As String = GetStringFromUserInput("CAD", "何をしましょうか?")
If userInput.Contains("直線") Then
CreateLine()
ElseIf userInput.Contains("円") Then
CreateCircle()
Else
ed.WriteMessage("そのような操作はできません。")
End If
End Sub
Private Sub CreateLine()
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim ed As Editor = doc.Editor
Dim start_x As Double = GetDoubleFromUserInput("始点のX座標を入力してください。")
Dim start_y As Double = GetDoubleFromUserInput("始点のY座標を入力してください。")
Dim end_x As Double = GetDoubleFromUserInput("終点のX座標を入力してください。")
Dim end_y As Double = GetDoubleFromUserInput("終点のY座標を入力してください。")
DrawLine(start_x, start_y, end_x, end_y)
End Sub
Private Sub CreateCircle()
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim ed As Editor = doc.Editor
Dim center_x As Double = GetDoubleFromUserInput("中心のX座標を入力してください。")
Dim center_y As Double = GetDoubleFromUserInput("中心のY座標を入力してください。")
Dim radius As Double = GetDoubleFromUserInput("半径を入力してください。")
DrawCircle(center_x, center_y, radius)
End Sub
Private Function GetDoubleFromUserInput(prompt As String) As Double
Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
While True
Dim result As PromptDoubleResult = ed.GetDouble(prompt)
If result.Status = PromptStatus.OK Then
Return result.Value
Else
ed.WriteMessage("数値を入力してください。")
End If
End While
' この行は通常、到達されませんが、関数のすべてのコードパスで値が返されることを確認します
Return 0.0
End Function
Private Function GetStringFromUserInput(title As String, prompt As String) As String
Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
Return ed.GetString(prompt).StringResult
End Function
Private Sub DrawLine(startX As Double, startY As Double, endX As Double, endY As Double)
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Using tr As Transaction = db.TransactionManager.StartTransaction()
Dim bt As BlockTable = tr.GetObject(db.BlockTableId, OpenMode.ForRead)
Dim btr As BlockTableRecord = tr.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
Dim startPoint As New Point3d(startX, startY, 0)
Dim endPoint As New Point3d(endX, endY, 0)
Dim line As New Line(startPoint, endPoint)
btr.AppendEntity(line)
tr.AddNewlyCreatedDBObject(line, True)
tr.Commit()
End Using
End Sub
Private Sub DrawCircle(centerX As Double, centerY As Double, radius As Double)
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Using tr As Transaction = db.TransactionManager.StartTransaction()
Dim bt As BlockTable = tr.GetObject(db.BlockTableId, OpenMode.ForRead)
Dim btr As BlockTableRecord = tr.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
Dim centerPoint As New Point3d(centerX, centerY, 0)
Dim circle As New Circle(centerPoint, Vector3d.ZAxis, radius)
btr.AppendEntity(circle)
tr.AddNewlyCreatedDBObject(circle, True)
tr.Commit()
End Using
End Sub
End Class
botというコマンドを入力すると、何をしましょうか?と訊いてきて、
円と入力すると中心のX座標、Y座標、そして半径の入力を求めてくる。
直線と入力すると始点のX座標、Y座標、終点のX座標、Y座標の入力を求めてくる。
とりあえず目標達成となった。
あとはいろいろな機能を追加していくだけとなった。




こうすれば一つの機能に好きなコマンド名をいくらでも割当てられることが分かった。



見事に成功!



Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Runtime
Public Class DrawLineCommands
<CommandMethod("DrawLine")>
Public Sub DrawLine()
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
' 1. 始点の座標を入力するダイアログボックスを表示する
Dim startPoint As PromptPointResult = ed.GetPoint("始点の座標を入力してください:")
If startPoint.Status <> PromptStatus.OK Then
Return
End If
' 2. 終点の座標を入力するダイアログボックスを表示する
Dim endPoint As PromptPointResult = ed.GetPoint("終点の座標を入力してください:")
If endPoint.Status <> PromptStatus.OK Then
Return
End If
' 3. 入力された座標を反映する
Using tr As Transaction = db.TransactionManager.StartTransaction()
Dim bt As BlockTable = tr.GetObject(db.BlockTableId, OpenMode.ForRead)
Dim btr As BlockTableRecord = tr.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
Dim line As New Line(startPoint.Value, endPoint.Value)
btr.AppendEntity(line)
tr.AddNewlyCreatedDBObject(line, True)
tr.Commit()
End Using
ed.WriteMessage("Line drawn successfully.")
End Sub
End Class
ChatGPTには座標入力コンポーネントの表示をしてくれと頼んだが、コマンド入力ボックスの上に始点(または終点)の座標を入力してくださいと表示されるにとどまった。
ちなみに写真では、一本目の直線の終点に二本目の直線の始点に選んでコマンド”DrawLine”を入力すると、
再度チャットボットの会話が始まり、終点の入力を促される。
まだ少々問題点が残ったが、やりたいことに向けて着々と進んでいる!
【追伸】
この直線描画CHATBOTはいちいち座標を入力する必要がない。マウスを動かして任意の位置にポインターをあわせてワンクリックし、始点や終点として選べるようになっている。
すでに出来上がったエレメントの端点にポインターを合わせれば、そこを始点に直線をひける。
改造したのはこの部分だけwww
Private Function GetResponse(input As String) As String
' ユーザーの入力に応じて適切な応答を生成
Select Case input.ToLower()
Case "バカ!", "アホ"
Return "何だテメェゴルァ!凸(◎曲◎♯)"
Case "かかってこいよ"
Return "ヘタレ!"
Case "口先番長", "詐欺師", "バカチョン"
Return "一昨日きやがれ!"
Case Else
Return "日本語しゃべれねーのか?このバカチョンチャンコロめが!"
End Select
文字化けするかな?と思ったが、あっさり成功。
バカ!またはアホと入力すると、
何だテメェゴルァ!凸(◎曲◎♯)
と顔文字付きでレスが来るのが今回狙った改造箇所。
CaseやReturnの””内は自由に変えられるし、AまたはBまたはCと入力が変わる場合、
Case "A", "B", "C"のように「,」で区切ればよい。
ソースコードはVB.NET。
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Runtime
Public Class ChatBotCommands
<CommandMethod("CHATBOT")>
Public Sub StartChatBot()
Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
While True
Dim userInput As String = GetUserInput("You: ")
Dim response As String = GetResponse(userInput)
ed.WriteMessage($"Bot: {response}" & vbCrLf)
End While
End Sub
Private Function GetUserInput(prompt As String) As String
Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
Dim options As PromptStringOptions = New PromptStringOptions(prompt)
options.AllowSpaces = True
Dim result As PromptResult = ed.GetString(options)
If result.Status = PromptStatus.OK Then
Return result.StringResult
Else
Return String.Empty
End If
End Function
Private Function GetResponse(input As String) As String
' ユーザーの入力に応じて適切な応答を生成
Select Case input.ToLower()
Case "hello", "hi"
Return "Hello! How can I help you?"
Case "how are you?"
Return "I'm just a program, so I don't have feelings, but thanks for asking!"
Case "bye", "exit", "quit"
Return "Goodbye! Have a great day!"
Case Else
Return "I'm sorry, I didn't understand that."
End Select
End Function
End Class
Case1「 "hello", "hi"」と入力すると
Return "Hello! How can I help you?"
Case2 「"how are you?"」と入力すると
Return "I'm just a program, so I don't have feelings, but thanks for asking!"
Case3 "bye", "exit", "quit"
Return "Goodbye! Have a great day!"
Case Else 例えばFuck You!と入力すると・・・
Return "I'm sorry, I didn't understand that."
それ以外も同様となる。なかなか面白かった。
ちなみに、三角錐とか円錐とか、立方体を円柱でくり抜くとかちょっと高度なコードをChatGPTにコード生成させたらエラーばっかで全然だめだったので、チャットボットにしてみた。テトリスはAUTOLISPでは動いたが、VB.NETではだめだった。インベーダーゲームも試したがだめだった。
またまたChatGPTがやってくれた!すげーよ!マジ神!
指定した場所に半径300の球を一瞬で描いた。
最初は失敗したかな?と思ったが3D表示に変えると、金属光沢のある球ができていた。
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Runtime
Public Class Class1
<CommandMethod("SPHERE")>
Public Sub DrawSphere()
' ダイアログを表示して中心点を取得
Dim dialogResult As PromptPointResult = GetPoint("Specify center point: ")
If dialogResult.Status <> PromptStatus.OK Then
Exit Sub
End If
Dim centerPoint As Point3d = dialogResult.Value
' 半径300の球を描画
DrawSphere(centerPoint, 300)
End Sub
Private Function GetPoint(message As String) As PromptPointResult
Dim editor As Editor = Application.DocumentManager.MdiActiveDocument.Editor
Dim promptOptions As PromptPointOptions = New PromptPointOptions(message)
Dim pointResult As PromptPointResult = editor.GetPoint(promptOptions)
Return pointResult
End Function
Private Sub DrawSphere(centerPoint As Point3d, radius As Double)
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Using trans As Transaction = db.TransactionManager.StartTransaction()
Try
' ブロックテーブルとブロックテーブルレコードを開く
Dim bt As BlockTable = trans.GetObject(db.BlockTableId, OpenMode.ForRead)
Dim btr As BlockTableRecord = CType(trans.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite), BlockTableRecord)
' 半径300の球を作成
Dim sphere As Solid3d = New Solid3d()
sphere.CreateSphere(radius)
sphere.TransformBy(Matrix3d.Displacement(centerPoint.GetAsVector()))
btr.AppendEntity(sphere)
trans.AddNewlyCreatedDBObject(sphere, True)
trans.Commit()
Catch ex As Exception
Application.ShowAlertDialog("Error: " & ex.Message)
trans.Abort()
End Try
End Using
End Sub
End Class
一辺が100の五角形を描くVB.netプログラム。任意の中心を指定するだけ。
VBのソースコードの部分だけ以下のようにChatGPTに質問して書いてもらった。
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Runtime
Public Class Class1
<CommandMethod("PENTAGON")>
Public Sub DrawPentagon()
' ダイアログを表示して中心点を取得
Dim dialogResult As PromptPointResult = GetPoint("Specify center point: ")
If dialogResult.Status <> PromptStatus.OK Then
Exit Sub
End If
Dim centerPoint As Point3d = dialogResult.Value
' 一辺が100の五角形を描画
DrawRegularPentagon(centerPoint, 100)
End Sub
Private Function GetPoint(message As String) As PromptPointResult
Dim editor As Editor = Application.DocumentManager.MdiActiveDocument.Editor
Dim promptOptions As PromptPointOptions = New PromptPointOptions(message)
Dim pointResult As PromptPointResult = editor.GetPoint(promptOptions)
Return pointResult
End Function
Private Sub DrawRegularPentagon(centerPoint As Point3d, sideLength As Double)
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Using trans As Transaction = db.TransactionManager.StartTransaction()
Try
' ブロックテーブルとブロックテーブルレコードを開く
Dim bt As BlockTable = trans.GetObject(db.BlockTableId, OpenMode.ForRead)
Dim btr As BlockTableRecord = CType(trans.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite), BlockTableRecord)
' 一辺が100の五角形を作成
Dim pentagonPoints As Point2dCollection = GetRegularPentagonPoints(centerPoint, sideLength)
Dim poly As Polyline = New Polyline()
For Each point As Point2d In pentagonPoints
poly.AddVertexAt(poly.NumberOfVertices, point, 0, 0, 0)
Next
poly.Closed = True
btr.AppendEntity(poly)
trans.AddNewlyCreatedDBObject(poly, True)
trans.Commit()
Catch ex As Exception
Application.ShowAlertDialog("Error: " & ex.Message)
trans.Abort()
End Try
End Using
End Sub
Private Function GetRegularPentagonPoints(centerPoint As Point3d, sideLength As Double) As Point2dCollection
Dim points As Point2dCollection = New Point2dCollection()
For i As Integer = 0 To 4
Dim angle As Double = i * (2 * Math.PI) / 5
Dim x As Double = centerPoint.X + sideLength * Math.Cos(angle)
Dim y As Double = centerPoint.Y + sideLength * Math.Sin(angle)
points.Add(New Point2d(x, y))
Next
Return points
End Function
End Class
AutoCADでコマンド「PENTAGON」と入力し、中心を指定すると・・・
このように一瞬で一辺100の五角形が出現した。マウスでカチャカチャやったら何秒かかるだろうか?
小さなプログラムのブロックをたくさん作って組み合わせていけば、作図スピードが何十倍にも上がるのは言うまでもない。
最速攻略AutoCAD VB.NETマクロサンプル大全集AutoCAD2009/2010/2011/2012/2013対応 https://amzn.asia/d/gT7IIvT