Code: Select all
EnableExplicit
;/ options
Global n ;matrix rang A
Global depth = 8 ;iteration depth
Global showAll = #true ;show all results
Global showSuspicious = #true ;show all results which could imply new relations
Global showDefects = #true ;show defects found
Global silent = #False ;show only if current weylgroup has defects
;/ Decleration
Structure lc ;linear combination
Array lc.i(n)
EndStructure
Structure node ;calculation node
skip.i
s.i
Array v.lc(0)
Array *child.node(0)
*parent.node
EndStructure
Macro printLine(string)
If silent = #False : PrintN(string) : EndIf
EndMacro
Global Dim A.i(0,0) ;matrix A
Global Dim basic.lc(0,0) ;generators of weylgroup
Global Dim relations.s(0,0) ;relations of weylgroup
Global NewList matrices.s() ;matrices to calculate
Global NewMap resultList.s() ;result list
Global root.node ;root calculation node
;/ output
Procedure createOutput(*current.node,out.s,currentDepth.i)
;create the resultlist after calculation
Protected x.i,y.i
If currentDepth = 0
ClearMap(resultList())
EndIf
If currentDepth > depth Or *current\skip = #true
ProcedureReturn #False
EndIf
If *current\parent
out = Str(*current\s) + out
AddMapElement(resultList(),out)
For x=1 To n
For y=1 To n
resultList() + Str(*current\v(x)\lc(y)) + ","
Next
Next
EndIf
For x=1 To n
createOutput(*current\child(x),out,currentDepth+1)
Next
EndProcedure
;/ calc
Procedure.s setupMultipleString(string.s,count.i)
Protected x.i, out.s
For x=1 To count
out + string
Next
ProcedureReturn out
EndProcedure
Procedure setupA()
Protected x.i, y.i, row.s
n = CountString(matrices(),";")
Dim A(n,n)
For x=1 To n
row = StringField(matrices(),x,";")
For y=1 To n
A(x,y) = Val(StringField(row,y,","))
Next
Next
EndProcedure
Procedure freeRoot(*current.node = #False)
;sets up the root node of the calculation
Protected x.i
If *current = 0
ProcedureReturn #False
EndIf
If *current <> root
For x=0 To n
freeRoot(*current\child(x))
Next
Else
For x=0 To n
freeRoot(root\child(x))
Next
EndIf
If *current <> root
ClearStructure(*current,node)
FreeMemory(*current)
EndIf
EndProcedure
Procedure setupRoot()
;sets up the root node of the calculation
Protected x.i,y.i
Dim root\v(n)
Dim root\child(n)
For x=1 To n
Dim root\v(x)\lc(n)
Next
For x=1 To n
For y=1 To n
If x=y
root\v(x)\lc(y) = 1
EndIf
Next
Next
EndProcedure
Procedure setupBasic()
;sets up the calculation of the genererators for later usage
Protected x.i,y.i,z.i
Dim basic.lc(n,n)
For x=1 To n
For y=1 To n
Dim basic(x,y)\lc(n)
Next
Next
For x=1 To n
For y=1 To n
For z=1 To n
basic(x,y)\lc(z) = 0
Next
Next
Next
For x=1 To n
For y=1 To n
basic(x,y)\lc(y) + 1
basic(x,y)\lc(x) - A(x,y)
Next
Next
EndProcedure
Procedure setupRelations()
Protected x.i,y.i
Dim relations.s(n,n)
For x=1 To n
For y=1 To n
If x=y
relations(x,y) = Str(x) + Str(y)
Else
Select A(x,y) * A(y,x)
Case 0
If A(x,y) = A(y,x)
relations(x,y) = setupMultipleString(Str(x) + Str(y),2)
EndIf
Case 1 : relations(x,y) = setupMultipleString(Str(x) + Str(y),3)
Case 2 : relations(x,y) = setupMultipleString(Str(x) + Str(y),4)
Case 3 : relations(x,y) = setupMultipleString(Str(x) + Str(y),6)
Default : relations(x,y) = ""
EndSelect
EndIf
Next
Next
EndProcedure
Procedure calculate_helper(*current.node)
;calculate specific node
Protected x.i,y.i,z.i
Protected temp.lc : Dim temp\lc(n)
For x=1 To n
For y=1 To n
For z=1 To n
temp\lc(z) + *current\parent\v(x)\lc(y) * basic(*current\s,y)\lc(z)
Next
Next
For z=1 To n
*current\v(x)\lc(z) = temp\lc(z)
temp\lc(z) = 0
Next
Next
EndProcedure
Procedure calculate(*current.node,currentDepth.i)
;build up calculation nodes
Protected x.i,y.i
If currentDepth > depth
ProcedureReturn #False
EndIf
;calculate current
If *current\parent
If *current\s <> *current\parent\s
calculate_helper(*current)
Else
*current\skip = #true
EndIf
EndIf
;create next level
For x=1 To n
*current\child(x) = AllocateMemory(SizeOf(node))
InitializeStructure(*current\child(x),node)
Dim *current\child(x)\v(n)
Dim *current\child(x)\child(n)
For y=1 To n
Dim *current\child(x)\v(y)\lc(n)
Next
*current\child(x)\parent = *current
*current\child(x)\s = x
Next
For x=1 To n
calculate(*current\child(x),currentDepth+1)
Next
EndProcedure
;/ proceed
Procedure.s prepareKey(keyS_A.s,keyS_B.s)
Protected x.i,y.i,position.i,cancel.i
Protected check_key.s
check_key = keyS_A + ReverseString(keyS_B)
Repeat
cancel = #true
For x=1 To n
For y=1 To n
If relations(x,y) <> ""
position = FindString(check_key,relations(x,y))
If position
check_key = ReplaceString(check_key,relations(x,y),"",#False,position)
cancel = #False
EndIf
EndIf
Next
Next
Until cancel = #true Or check_key = ""
ProcedureReturn check_key
EndProcedure
Procedure showMatrix(additional.s = "")
;show current Matrix
Protected matrix.s, x.i, y.i
For x=1 To n
For y=1 To n
matrix + Str(A(x,y)) + ","
Next
matrix + ";"
Next
PrintN("A = " + matrix + " " + additional)
EndProcedure
Procedure showDefects(Map suspicious.i())
;show all defects found
Protected keyS_X.s, keyS_Y.s, keyS_Z.s, keyV_Z.s, keyV_A.s, keyV_B.s, s.s
Protected currentS.s, lenS.i, x.i, cancel.i
printLine(#crlf$+"defects:")
ForEach suspicious()
currentS = MapKey(suspicious())
lenS = Len(currentS)
If Len(currentS)%2 = 0
keyS_X = ReverseString(Mid(currentS,Len(currentS)/2))
keyS_Y = Left(currentS,Len(currentS)/2-1)
Else
keyS_X = ReverseString(Mid(currentS,Len(currentS)/2+1))
keyS_Y = Left(currentS,Len(currentS)/2)
EndIf
keyS_Z = Left(keyS_X, Len(keyS_X)-1)
s = Right(keyS_X,1)
If FindMapElement(resultList(),keyS_Z)
keyV_Z = resultList()
Else
Continue
EndIf
cancel = #False
ForEach resultList()
If resultList() = keyV_Z
If Len(MapKey(resultList())) < Len(keyS_Z)
cancel = #true
Break
EndIf
EndIf
Next
For x=1 To Len(keyS_Z)
FindMapElement(resultList(),Mid(keyS_Z,x))
keyV_A = resultList()
FindMapElement(resultList(),Mid(keyS_Z,x+1)+s)
keyV_B = resultList()
If keyV_A = keyV_B
cancel = #true
Break
EndIf
Next
If cancel = #False
printLine(RSet(keyS_X,depth) + " // " + RSet(keyS_Y,depth) + " // " + RSet(keyS_Z,depth))
If silent
showMatrix("defect found")
ProcedureReturn #true
EndIf
EndIf
Next
If silent
showMatrix()
EndIf
EndProcedure
Procedure showSuspicious()
;show all results with suspicious relations
Protected x.i, y.i, storePosition.i
Protected keyV_A.s, keyV_B.s, keyS_A.s, keyS_B.s, key.s, identity.s
NewMap suspicious.i()
For x=1 To n
For y=1 To n
If x=y
identity + "1,"
Else
identity + "0,"
EndIf
Next
Next
ForEach resultList()
keyV_A = resultList()
keyS_A = MapKey(resultList())
PushMapPosition(resultList())
While NextMapElement(resultList())
keyV_B = resultList()
keyS_B = MapKey(resultList())
If keyV_A = keyV_B
key = prepareKey(keyS_A,keyS_B)
If key = "" : Continue : EndIf
AddMapElement(suspicious(),key)
EndIf
Wend
PopMapPosition(resultList())
Next
If showSuspicious
printLine(#crlf$ + "suspicious:")
ForEach suspicious()
printLine(RSet(MapKey(suspicious()),2*depth) + " // "+ identity)
Next
EndIf
If showDefects Or silent
printLine(#crlf$ + "calculating defects")
showDefects(suspicious())
EndIf
EndProcedure
Procedure showAll()
;show all results
Protected NewList out.s()
ForEach resultList()
AddElement(out())
out() = RSet(MapKey(resultList()),depth) + " // " + resultList()
Next
SortList(out(),#pb_sort_ascending)
printLine(#crlf$ + "all:")
ForEach out()
printLine(out())
Next
EndProcedure
Procedure start()
Protected x.i,y.i,current.s
OpenConsole()
ConsoleTitle ("Calculate Weyl-Group")
For x=1 To CountProgramParameters()
current = ProgramParameter()
Select LCase(current)
Case "all1" : showAll = #true
Case "all0" : showAll = #False
Case "suspicious1" : showSuspicious = #true
Case "suspicious0" : showSuspicious = #False
Case "defects1" : showDefects = #true
Case "defects0" : showDefects = #False
Case "silent1" : silent = #true
Case "silent0" : silent = #False
Default
If LCase(Left(current,5)) = "depth"
depth = Val(Mid(current,6))
Else
AddElement(matrices()) : matrices() = current
EndIf
EndSelect
Next
If ListSize(matrices()) = 0
PrintN("at least one matrix A must be defined")
ProcedureReturn #False
EndIf
ForEach matrices()
setupA()
setupRoot()
setupBasic()
setupRelations()
If silent = #False : showMatrix() : EndIf
printLine(#crlf$ + "calculating weylgroup")
calculate(@root,0)
createOutput(@root,"",0)
If showAll : showAll() : EndIf
If showSuspicious Or showDefects Or silent
printLine(#crlf$ + "calculating suspicious")
showSuspicious()
EndIf
freeRoot(root)
printLine("")
Next
PrintN("done")
EndProcedure
start()
And it's no
