Навигация

О программе

Алгоритм программы

Код программы

 
исходный код программы

Rem ******** Начало программы ********

Option Explicit

Rem объекты FileSystemObject и TextStream
Dim fso, MyFile

Rem Что за чем идёт (массивы последовательностей, например в arrB все символы, следующие за B)
Dim arrA, arrB, arrC, arrD, arrE, arrF, arrG, arrH, arrI, arrJ, arrK, arrL, arrM, arrN, arrO, arrP, arrQ, arrR, arrS, arrT, arrU, arrV, arrW, arrX, arrY, arrZ
Rem Исключения 2 A подряд и 2 O подряд
Dim arrAA, arrOO

Rem Алфавит
Dim arrABC

Rem максимальный уровень и текущий уровень (текущая длина) генерации
Dim iMaxLevel, iCurrentLevel

Rem в каком формате генерируем имена ("txt", "xml")...
Dim sTarget

Rem общее кол-во сгенерированных названий (также может использоваться как id)
Dim iCount

Private Sub Command1_Click()
  Command1.Enabled = False
  iMaxLevel = CInt(Combo1.Text)
  sTarget = Combo2.Text
  DrawName arrABC
  Command1.Enabled = True
End Sub

Private Sub Form_Load()
  Dim i
  arrABC = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
  arrA = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
  arrB = Array("A", "E", "I", "O", "U", "Y", "L", "R")
  arrC = Array("A", "E", "I", "O", "U", "Y", "H", "K", "L", "R")
  arrD = Array("A", "E", "I", "O", "U", "R")
  arrE = Array("B", "C", "D", "F", "G", "H", "I", "K", "L", "M", "N", "P", "R", "S", "T", "U", "V")
  arrF = Array("A", "E", "I", "L", "O", "R", "U")
  arrG = Array("A", "E", "I", "L", "O", "R", "U")
  arrH = Array("A", "E", "I", "O", "U")
  arrI = Array("A", "B", "C", "D", "E", "F", "G", "H", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "V", "W", "X", "Z")
  arrJ = Array("A", "E", "I", "O", "U")
  arrK = Array("A", "E", "I", "L", "N", "O", "R", "U")
  arrL = Array("A", "E", "I", "O", "U", "Y")
  arrM = Array("A", "E", "I", "O", "U", "Y")
  arrN = Array("A", "E", "I", "O", "U", "Y")
  arrO = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
  arrP = Array("A", "E", "H", "I", "L", "O", "R", "U")
  arrQ = Array("U")
  arrR = Array("A", "E", "I", "O", "U", "Y")
  arrS = Array("A", "C", "E", "H", "I", "K", "L", "M", "N", "O", "P", "R", "T", "U", "V", "W", "Y")
  arrT = Array("A", "E", "H", "I", "O", "R", "U", "Y")
  arrU = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "R", "S", "T", "V", "W", "X", "Y", "Z")
  arrV = Array("A", "E", "I", "O")
  arrW = Array("A", "E", "H", "I", "O")
  arrX = Array("A", "E", "I", "O")
  arrY = Array("A", "B", "C", "D", "E", "L", "M", "N", "O", "P", "R", "S", "T", "U")
  arrZ = Array("A", "E", "H", "I", "O", "U")

  Rem 3A (три A) и 3O (три O) подряд быть не может
  arrAA = Array("B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
  arrOO = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "P", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")

  Rem пользователь выберет максимальную длину генерации
  Rem свойства уже добавлены в компоненте
  Rem For i = 2 To 15
  Rem Combo1.AddItem i
  Rem Next

  Rem свойства уже добавлены в компоненте
  Rem Combo2.AddItem "txt"
  Rem Combo2.AddItem "xml"
End Sub

Private Function DrawName(CurrentArr)
  Dim i, j
  Dim sFileName

  If sTarget = "xml" Then
   sFileName = "names.xml"
   Rem В противном случае "txt"
  Else
   sFileName = "names.txt"
  End If

  Set fso = CreateObject("Scripting.FileSystemObject")
  Set MyFile = fso.CreateTextFile(sFileName, True)

  If sTarget = "xml" Then
   MyFile.WriteLine "<?xml version=""1.0"" encoding=""windows-1251""?>"
   MyFile.WriteLine "<names>"
  End If

  iCurrentLevel = 1
  iCount = 0

  For i = 0 To UBound(CurrentArr)
   Select Case CurrentArr(i)
   Case "A"
   For j = 0 To UBound(arrA)
    DrawCurrentString CurrentArr(i) & arrA(j), CurrentArr(i), arrA(j)
   Next
   Case "B"
   For j = 0 To UBound(arrB)
    DrawCurrentString CurrentArr(i) & arrB(j), CurrentArr(i), arrB(j)
   Next
   Case "C"
   For j = 0 To UBound(arrC)
    DrawCurrentString CurrentArr(i) & arrC(j), CurrentArr(i), arrC(j)
   Next
   Case "D"
   For j = 0 To UBound(arrD)
    DrawCurrentString CurrentArr(i) & arrD(j), CurrentArr(i), arrD(j)
   Next
   Case "E"
   For j = 0 To UBound(arrE)
    DrawCurrentString CurrentArr(i) & arrE(j), CurrentArr(i), arrE(j)
   Next
   Case "F"
   For j = 0 To UBound(arrF)
    DrawCurrentString CurrentArr(i) & arrF(j), CurrentArr(i), arrF(j)
   Next
   Case "G"
   For j = 0 To UBound(arrG)
    DrawCurrentString CurrentArr(i) & arrG(j), CurrentArr(i), arrG(j)
   Next
   Case "H"
   For j = 0 To UBound(arrH)
    DrawCurrentString CurrentArr(i) & arrH(j), CurrentArr(i), arrH(j)
   Next
   Case "I"
   For j = 0 To UBound(arrI)
    DrawCurrentString CurrentArr(i) & arrI(j), CurrentArr(i), arrI(j)
   Next
   Case "J"
   For j = 0 To UBound(arrJ)
    DrawCurrentString CurrentArr(i) & arrJ(j), CurrentArr(i), arrJ(j)
   Next
   Case "K"
   For j = 0 To UBound(arrK)
    DrawCurrentString CurrentArr(i) & arrK(j), CurrentArr(i), arrK(j)
   Next
   Case "L"
   For j = 0 To UBound(arrL)
    DrawCurrentString CurrentArr(i) & arrL(j), CurrentArr(i), arrL(j)
   Next
   Case "M"
   For j = 0 To UBound(arrM)
    DrawCurrentString CurrentArr(i) & arrM(j), CurrentArr(i), arrM(j)
   Next
   Case "N"
   For j = 0 To UBound(arrN)
    DrawCurrentString CurrentArr(i) & arrN(j), CurrentArr(i), arrN(j)
   Next
   Case "O"
   For j = 0 To UBound(arrO)
    DrawCurrentString CurrentArr(i) & arrO(j), CurrentArr(i), arrO(j)
   Next
   Case "P"
   For j = 0 To UBound(arrP)
    DrawCurrentString CurrentArr(i) & arrP(j), CurrentArr(i), arrP(j)
   Next
   Case "Q"
   For j = 0 To UBound(arrQ)
    DrawCurrentString CurrentArr(i) & arrQ(j), CurrentArr(i), arrQ(j)
   Next
   Case "R"
   For j = 0 To UBound(arrR)
    DrawCurrentString CurrentArr(i) & arrR(j), CurrentArr(i), arrR(j)
   Next
   Case "S"
   For j = 0 To UBound(arrS)
    DrawCurrentString CurrentArr(i) & arrS(j), CurrentArr(i), arrS(j)
   Next
   Case "T"
   For j = 0 To UBound(arrT)
    DrawCurrentString CurrentArr(i) & arrT(j), CurrentArr(i), arrT(j)
   Next
   Case "U"
   For j = 0 To UBound(arrU)
    DrawCurrentString CurrentArr(i) & arrU(j), CurrentArr(i), arrU(j)
   Next
   Case "V"
   For j = 0 To UBound(arrV)
    DrawCurrentString CurrentArr(i) & arrV(j), CurrentArr(i), arrV(j)
   Next
   Case "W"
   For j = 0 To UBound(arrW)
    DrawCurrentString CurrentArr(i) & arrW(j), CurrentArr(i), arrW(j)
   Next
   Case "X"
   For j = 0 To UBound(arrX)
    DrawCurrentString CurrentArr(i) & arrX(j), CurrentArr(i), arrX(j)
   Next
   Case "Y"
   For j = 0 To UBound(arrY)
    DrawCurrentString CurrentArr(i) & arrY(j), CurrentArr(i), arrY(j)
   Next
   Case "Z"
   For j = 0 To UBound(arrZ)
    DrawCurrentString CurrentArr(i) & arrZ(j), CurrentArr(i), arrZ(j)
   Next
   End Select
  Next

  If sTarget = "xml" Then
   MyFile.WriteLine "</names>"
  End If
  MyFile.Close

  MsgBox iCount & " names generation"
End Function

Rem функции передаётся текущая строка с предыдущим и последним символом в ней
Private Function DrawCurrentString(sCurrentString, previousChar, lastChar)
  Dim i

  Rem запишем в файл текущую строку и затем займёмся её перебором
  Rem MyFile.WriteLine sCurrentString & " " & iCurrentLevel & " " & iMaxLevel
  WriteLineToFile sCurrentString

  Rem считаем текущий уровень (длину) - если мы подошли к максимуму прекращаем перебор
  iCurrentLevel = iCurrentLevel + 1
  If iCurrentLevel < iMaxLevel Then

   Select Case lastChar
   Case "A"
   If lastChar = "A" And previousChar = "A" Then
    For i = 0 To UBound(arrAA)
     DrawCurrentString sCurrentString & arrAA(i), lastChar, arrAA(i)
    Next
   Else
    For i = 0 To UBound(arrA)
     DrawCurrentString sCurrentString & arrA(i), lastChar, arrA(i)
    Next
   End If
   Case "B"
   For i = 0 To UBound(arrB)
    DrawCurrentString sCurrentString & arrB(i), lastChar, arrB(i)
   Next
   Case "C"
   For i = 0 To UBound(arrC)
    DrawCurrentString sCurrentString & arrC(i), lastChar, arrC(i)
   Next
   Case "D"
   For i = 0 To UBound(arrD)
    DrawCurrentString sCurrentString & arrD(i), lastChar, arrD(i)
   Next
   Case "E"
   For i = 0 To UBound(arrE)
    DrawCurrentString sCurrentString & arrE(i), lastChar, arrE(i)
   Next
   Case "F"
   For i = 0 To UBound(arrF)
    DrawCurrentString sCurrentString & arrF(i), lastChar, arrF(i)
   Next
   Case "G"
   For i = 0 To UBound(arrG)
    DrawCurrentString sCurrentString & arrG(i), lastChar, arrG(i)
   Next
   Case "H"
   For i = 0 To UBound(arrH)
    DrawCurrentString sCurrentString & arrH(i), lastChar, arrH(i)
   Next
   Case "I"
   For i = 0 To UBound(arrI)
    DrawCurrentString sCurrentString & arrI(i), lastChar, arrI(i)
   Next
   Case "J"
   For i = 0 To UBound(arrJ)
    DrawCurrentString sCurrentString & arrJ(i), lastChar, arrJ(i)
   Next
   Case "K"
   For i = 0 To UBound(arrK)
    DrawCurrentString sCurrentString & arrK(i), lastChar, arrK(i)
   Next
   Case "L"
   For i = 0 To UBound(arrL)
    DrawCurrentString sCurrentString & arrL(i), lastChar, arrL(i)
   Next
   Case "M"
   For i = 0 To UBound(arrM)
    DrawCurrentString sCurrentString & arrM(i), lastChar, arrM(i)
   Next
   Case "N"
   For i = 0 To UBound(arrN)
    DrawCurrentString sCurrentString & arrN(i), lastChar, arrN(i)
   Next
   Case "O"
   If lastChar = "O" And previousChar = "O" Then
    For i = 0 To UBound(arrOO)
     DrawCurrentString sCurrentString & arrOO(i), lastChar, arrOO(i)
    Next
   Else
    For i = 0 To UBound(arrO)
     DrawCurrentString sCurrentString & arrO(i), lastChar, arrO(i)
    Next
   End If
   Case "P"
   For i = 0 To UBound(arrP)
    DrawCurrentString sCurrentString & arrP(i), lastChar, arrP(i)
   Next
   Case "Q"
   For i = 0 To UBound(arrQ)
    DrawCurrentString sCurrentString & arrQ(i), lastChar, arrQ(i)
   Next
   Case "R"
   For i = 0 To UBound(arrR)
    DrawCurrentString sCurrentString & arrR(i), lastChar, arrR(i)
   Next
   Case "S"
   For i = 0 To UBound(arrS)
    DrawCurrentString sCurrentString & arrS(i), lastChar, arrS(i)
   Next
   Case "T"
   For i = 0 To UBound(arrT)
    DrawCurrentString sCurrentString & arrT(i), lastChar, arrT(i)
   Next
   Case "U"
   For i = 0 To UBound(arrU)
    DrawCurrentString sCurrentString & arrU(i), lastChar, arrU(i)
   Next
   Case "V"
   For i = 0 To UBound(arrV)
    DrawCurrentString sCurrentString & arrV(i), lastChar, arrV(i)
   Next
   Case "W"
   For i = 0 To UBound(arrW)
    DrawCurrentString sCurrentString & arrW(i), lastChar, arrW(i)
   Next
   Case "X"
   For i = 0 To UBound(arrX)
    DrawCurrentString sCurrentString & arrX(i), lastChar, arrX(i)
   Next
   Case "Y"
   For i = 0 To UBound(arrY)
    DrawCurrentString sCurrentString & arrY(i), lastChar, arrY(i)
   Next
   Case "Z"
   For i = 0 To UBound(arrZ)
    DrawCurrentString sCurrentString & arrZ(i), lastChar, arrZ(i)
   Next
   End Select
  End If
  iCurrentLevel = iCurrentLevel - 1
End Function

Private Function WriteLineToFile(s)
  Dim xmls
  iCount = iCount + 1
  If sTarget = "xml" Then
   xmls = "<item name=""" & s & """ id=""" & iCount & """/>"
   MyFile.WriteLine xmls
  Else
   MyFile.WriteLine s
  End If
End Function

Rem ******** Конец программы ********


И, напоследок, минута прекрасного: пейзаж.ру.



Реклама на сайте  

ГЛАВНАЯ СТРАНИЦА

Copyright © 2008 Программа генерации английских названий