Алгоритм хочу

Сомневаюсь, что это кого-нибудь заинтересует, но все-таки спрошу.
Решил я тут на днях сделать простенький клиент для KataGo (мощный движок для игры в го с возможностью анализа)
и столкнулся с задачей определения мертвых групп. Когда-то, очень давно, я успешно эту задачу решал на BlitzBasic (тогда еще не было PB).
Но с тех пор и код был утерян, и тот скромный навык который был, и сообразительность. И теперь не могу допетрить - как я это делал.
Потому тупо спросил у Алисы...
На удивление она выдала почти рабочий код, который я здесь привожу с некоторыми исправлениями и дополнениями.
Это работает, но сам алгоритм какой-то, скажем так, слишком трудоемкий.
Да, можно сделать так, чтобы анализ запускался только при контактном ходе с камнем другого цвета (а не после каждого хода),
но этого мало. Нужен другой алгоритм - я ведь делал это как-то иначе (и без рекурсии, и без списков, и без необходимости проверять
после каждого хода ВСЕ группы на доске).
Может кто натолкнет на мысль?

Код:

Global Dim board(18, 18), Dim visited(18, 18), col=1 ; col=1 - черные камни, col=2 - белые

Structure StoneGroup ; для координат камней в группе
  x.i
  y.i
EndStructure

Procedure FindGroup(x, y, color, List group.StoneGroup()) ; Поиск группы
  If x < 0 Or x >18 Or y < 0 Or y > 18  ; Проверка границ доски
    ProcedureReturn
  EndIf  
  If visited(x, y) Or board(x, y) <> color ; Если клетка уже посещена или цвет не совпадает — выход
    ProcedureReturn
  EndIf
  visited(x, y) = 1  ; Помечаем как посещённую
  AddElement(group()) ; Добавляем камень в группу
  group()\x = x
  group()\y = y
  ; Рекурсивно обходим соседей (4 направления)
  FindGroup(x - 1, y, color, group())  ; влево
  FindGroup(x + 1, y, color, group())  ; вправо
  FindGroup(x, y - 1, color, group())  ; вверх
  FindGroup(x, y + 1, color, group())  ; вниз
EndProcedure

Procedure Liberty(List group.StoneGroup()) ; Есть ли дамэ (свободный пункт) у группы?
  ForEach group()
    x = group()\x
    y = group()\y
    ; Проверяем 4 соседних пункта
    If x > 0 And board(x - 1, y) = 0 : ProcedureReturn 1 : EndIf
    If x < 18 And board(x + 1, y) = 0 : ProcedureReturn 1 : EndIf
    If y > 0 And board(x, y - 1) = 0 : ProcedureReturn 1 : EndIf
    If y < 18 And board(x, y + 1) = 0 : ProcedureReturn 1 : EndIf
  Next
  ProcedureReturn 0  ; Нет ни одного дамэ
EndProcedure

Procedure RemoveDead(targetColor) ; Удаление мёртвых групп заданного цвета
  For x = 0 To 18  ; Сбрасываем флаги посещения
    For y = 0 To 18
      visited(x, y) = 0
    Next
  Next
  For x = 0 To 18  ; Проходим по всем клеткам доски
    For y = 0 To 18
      If board(x, y) = targetColor And Not visited(x, y)  ; Камень нужного цвета и не посещён
        NewList group.StoneGroup()
        FindGroup(x, y, targetColor, group())
        If Not Liberty(group())  ; Группа мёртвая — удаляем
          Debug "Удалена группа (" + Str(x) + "," + Str(y) + ") (цвет: " + Str(targetColor) + ")"
          ForEach group()
            board(group()\x, group()\y) = 0  ; Очищаем клетку
          Next
        EndIf
        ClearList(group())
      EndIf
    Next
  Next
EndProcedure

Procedure PrintBoard()   ; Вывод доски (для отладки)
  StartDrawing(CanvasOutput(1))
  DrawImage(ImageID(0), 0, 0)
  For y = 0 To 18
    For x = 0 To 18
      If board(x, y)
        DrawAlphaImage(ImageID(board(x, y)), x*39, y*39)
      EndIf
    Next
  Next
  StopDrawing()
EndProcedure

Procedure clik() ; Левый клик на доске
  x=GetGadgetAttribute(1, #PB_Canvas_MouseX)/39
  y=GetGadgetAttribute(1, #PB_Canvas_MouseY)/39
  If x<19 And y<19 And board(x,y)=0
    board(x,y)=col
    RemoveDead(3-col)
    PrintBoard()
    col=3-col
  EndIf
EndProcedure

Procedure risunok() ; Для визуализации работы алгоритма
  StartDrawing(ImageOutput(0))
  For i=21 To 741 Step 39
    LineXY(21, i, 723, i, 0) : LineXY(i, 21, i, 723, 0)
  Next
  DrawingMode(#PB_2DDrawing_Outlined) : Box(20, 20, 705, 705, 0)
  StopDrawing()
  For i=1 To 2
    StartDrawing(ImageOutput(i))
    DrawingMode(#PB_2DDrawing_Outlined | #PB_2DDrawing_AlphaBlend)
    Circle(21, 21, 18, RGBA(5, 5, 5, 255))
    FillArea(21, 21, RGB(5, 5, 5), RGBA(60*i*i, 60*i*i, 60*i*i, 255))
    StopDrawing()
  Next
  SetGadgetAttribute(1,#PB_Canvas_Image,ImageID(0))
EndProcedure

; ---------- ОСНОВНАЯ ПРОГРАММА ----------
OpenWindow(0, 0, 0, 756, 756, "Algorithm", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
SetWindowColor(0, $6699CC)
CanvasGadget(1, 6, 6, 745, 745)
CreateImage(0, 745, 745, 24, $77CEFF)
CreateImage(1, 43, 43 ,32, #PB_Image_Transparent)
CreateImage(2, 43, 43 ,32, #PB_Image_Transparent)

risunok() ; Простенький рисунок доски и камней

Repeat
  Select WaitWindowEvent()
    Case  #PB_Event_CloseWindow
      End
    Case #PB_Event_Gadget
      If EventGadget()=1 And EventType()=#PB_EventType_LeftClick
        clik()
      EndIf
  EndSelect
ForEver

Лучше приведенного ниже у меня не получилось.

Код:

Global cl=1, Dim dsk(18,18), x, y, kg, ku, Dim ng(2), Dim nud(3), Dim hbw(1)

Procedure scan(xi,yi)
  If xi<0 Or xi>18 Or yi<0 Or yi>18 : ProcedureReturn : EndIf
  If dsk(xi,yi)
    If (2-cl)*dsk(xi,yi)>0
      If dsk(x,y)=0
        dsk(x,y)=dsk(xi,yi)  
      ElseIf dsk(xi,yi)<>dsk(x,y)
        ng(kg)=dsk(xi,yi) : kg+1
      EndIf
    Else
      nud(ku)=dsk(xi,yi) : ku+1
    EndIf
  EndIf
EndProcedure

Procedure prud(xi,yi)
  If xi>0 And dsk(xi-1,yi)=0 : ProcedureReturn 0 : EndIf
  If xi<18 And dsk(xi+1,yi)=0 : ProcedureReturn 0 : EndIf
  If yi>0 And dsk(xi,yi-1)=0 : ProcedureReturn 0 : EndIf
  If yi<18 And dsk(xi,yi+1)=0 : ProcedureReturn 0 : EndIf
  ProcedureReturn 1
EndProcedure

Procedure zamen()
  m=2-cl : t=kg-1 : s=ku-1
  For yi=0 To 18 : For xi=0 To 18
    If kg And (dsk(xi,yi)*m)>0
      For p=0 To t
        If dsk(xi,yi)=ng(p) : dsk(xi,yi)=dsk(x,y) : EndIf
      Next
    EndIf
    If ku And dsk(xi,yi)
      For p=0 To s
        If nud(p) And dsk(xi,yi)=nud(p)
          k=prud(xi,yi) : nud(p)*k : ku-Bool(k=0)
        EndIf
      Next
    EndIf
  Next : Next
EndProcedure

Procedure drwn(t)
  StartDrawing(CanvasOutput(1))
  DrawAlphaImage(ImageID(cl), x*39, y*39)
  If t
    DrawImage(ImageID(0), 0, 0)
    For yi = 0 To 18 : For xi = 0 To 18
      d=dsk(xi,yi)
      If d
        If d=nud(0) Or d=nud(1) Or d=nud(2) Or d=nud(3)
          dsk(xi,yi)=0 : udk+1
        Else
          DrawAlphaImage(ImageID(2-Sign(dsk(xi, yi))), xi*39, yi*39)
        EndIf
      EndIf
    Next : Next
    Debug "Удалено "+udk+Mid(" черных белых",1+Bool(cl=1)*7,7)+" камней"
  EndIf
  StopDrawing()
EndProcedure

Procedure anlz()
  drwn(0)
  kg=0 : ku=0 : Dim ng(2) : Dim nud(3)
  scan(x-1,y) : scan(x,y-1)
  scan(x+1,y) : scan(x,y+1)
  If dsk(x,y)=0 : f=Bool(cl=3) : hbw(f)+2-cl : dsk(x,y)=hbw(f) : EndIf
  If kg+ku : zamen() : EndIf
  If ku : drwn(1) : EndIf
EndProcedure

Procedure clik()
  x=GetGadgetAttribute(1, #PB_Canvas_MouseX)/39
  y=GetGadgetAttribute(1, #PB_Canvas_MouseY)/39
  If x<19 And y<19 And dsk(x,y)=0
    anlz()
    cl=4-cl
  EndIf
EndProcedure

Procedure risunok() ; Для визуализации работы алгоритма
  StartDrawing(ImageOutput(0))
  For i=21 To 741 Step 39
    LineXY(21, i, 723, i, 0) : LineXY(i, 21, i, 723, 0)
  Next
  DrawingMode(#PB_2DDrawing_Outlined) : Box(20, 20, 705, 705, 0)
  StopDrawing()
  For i=1 To 3 Step 2
    StartDrawing(ImageOutput(i))
    DrawingMode(#PB_2DDrawing_Outlined | #PB_2DDrawing_AlphaBlend)
    Circle(21, 21, 18, RGBA(5, 5, 5, 255))
    FillArea(21, 21, RGB(5, 5, 5), RGBA(60+k, 60+k, 60+k, 255))
    k+180
    StopDrawing()
  Next
  SetGadgetAttribute(1,#PB_Canvas_Image,ImageID(0))
EndProcedure

; ---------- ОСНОВНАЯ ПРОГРАММА ----------
OpenWindow(0, 0, 0, 756, 756, "Algorithm", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
SetWindowColor(0, $6699CC)
CanvasGadget(1, 6, 6, 745, 745)
CreateImage(0, 745, 745, 24, $77CEFF)
CreateImage(1, 43, 43 ,32, #PB_Image_Transparent)
CreateImage(3, 43, 43 ,32, #PB_Image_Transparent)

risunok() ; Простенький рисунок доски и камней

Repeat
  Select WaitWindowEvent()
    Case  #PB_Event_CloseWindow
      End
    Case #PB_Event_Gadget
      If EventGadget()=1 And EventType()=#PB_EventType_LeftClick
        clik()
      EndIf
  EndSelect
ForEver

поиск в директории	Вопросы по PureBasic	25.07.2010
Стабильный код передачи файлов	Вопросы по PureBasic	16.03.2014
Balloons	PureBasic для Windows	22.02.2023

PureBasic - форум

Меню навигации

Пользовательские ссылки

Информация о пользователе

Алгоритм хочу

Сообщений 1 страница 2 из 2

Поделиться127.12.2025 19:23:45

Поделиться2Вчера 20:55:04

Похожие темы