Bob
Function GetDesign (idoall As Integer)
'__
'__ GLOBAL GetDesign
'__
'__ called by frmDesign.lblDirective_Change
'__ called by frmDesign.mnuDefault_Click
'__ calls GLOBAL atomsel_findlowestphi
'__ calls GLOBAL atomsel_setphitheta
'__ calls GLOBAL atomsel_setxyz
'__ calls GLOBAL atomsel_shortest
'__ calls GLOBAL atomsel_tozaxis
'__ calls GLOBAL model_text
'__ calls GLOBAL checknewfacetype
'__ calls GLOBAL GetNewFace
'__
Dim i As Integer
Dim j As Integer
Dim s As String
Dim sedge As String * 2
Dim isel1 As Integer
Dim isel2 As Integer
Dim isel3 As Integer
Dim iface As Integer
Dim sface As String
Dim inew As Integer
Dim havenew13 As Integer
Dim havenew24 As Integer
Dim phi As angle
Dim isconvex As Integer
On Error GoTo designerror
gstr = "Unknown design error"
ReDim face(1)
ReDim facet(1)
'
nfaces = 0
nfacets = 0
strfacelist = ""
isdotted = True
'MsgBox "GetDesign: natomsel=" & natomsel
If natomsel = 0 Then Exit Function
If natomsel = 1 Then
GetDesign = "(a)"
Exit Function
End If
Call atomsel_setxyz
sedge = atomsel_shortest(isel2, isel1)
Call atomsel_tozaxis(sedge)
'shortest is now on zaxis, with isel2 at origin and isel1 +Z
'Debug.Print isel1, isel2, sedge
Call atomsel_setphitheta(0)
Call atomsel_dump(natomsel)
'atomsel(i).phideg is in reference to line of projection
'of central atom THROUGH origin (atom isel2)
isel3 = atomsel_findlowestphi() ' Call angle_set(phi, -atomsel(isel3).phideg) ' Call atomsel_zrotate(phi) ' Call atomsel_setphitheta(0) 'idea here is to find pt with clockwise face isel2,isel1,isel3 iface = GetNewFace(isel1, isel2, isel3, 0) Debug.Print iface & ":"; isel1, isel2, isel3, face(1).sface Do havenew13 = False havenew24 = False Do inew = checknewfacetype(1) + checknewfacetype(3) If inew Then havenew13 = True Loop Until inew = 0 Do inew = checknewfacetype(2) + checknewfacetype(4) If inew Then havenew24 = True Loop Until inew = 0 Loop While havenew13 Or havenew24
GetDesign = model_text(idoall) Exit Function designerror: MsgBox gstr Exit Function End Function
Function checknewfacetype (itype As Integer) As Integer '__ '__ GLOBAL checknewfacetype '__ '__ parameter itype As Integer '__ '__ called by GLOBAL GetDesign '__ calls GLOBAL atomsel_findlowestphi '__ calls GLOBAL atomsel_setphitheta '__ calls GLOBAL atomsel_tozaxis '__ calls GLOBAL GetNewFace '__
Dim i As Integer
Dim j As Integer
Dim s As String
Dim sedge As String * 2
Dim isel1 As Integer
Dim isel2 As Integer
Dim isel3 As Integer
Dim iface As Integer
Dim sface As String
Dim inew As Integer
j = itype
For i = 1 To nfaces'not new ones...
If face(i).iface(j) < 0 Then
'Debug.Print i, j
sface = Trim$(face(i).sface)
sface = sface & sface
isel1 = Asc(Mid$(sface, j + 1)) - 96
isel2 = Asc(Mid$(sface, j)) - 96
isel3 = Asc(Mid$(sface, j + 2)) - 96
sedge = Mid$(sface, j, 1) & Mid$(sface, j + 1, 1)
Call atomsel_tozaxis(sedge)
'Debug.Print isel1, isel2, isel3
Call atomsel_setphitheta(isel3)
'Debug.Print sedge, pt_show(0,atomsel(isel3).xyz), atomsel(isel3).phideg
isel3 = atomsel_findlowestphi()
face(i).iface(j) = GetNewFace(isel1, isel2, isel3, j)
inew = inew + face(i).iface(j)
End If
Next
checknewfacetype = inew
End FunctionFunction GetNewFace (ia1 As Integer, ia2 As Integer, ia3 As Integer, iconnect As Integer)
'__
'__ GLOBAL GetNewFace
'__
'__ parameter ia1 As Integer
'__ parameter ia2 As Integer
'__ parameter ia3 As Integer
'__ parameter iconnect As Integer
'__
'__ called by GLOBAL checknewfacetype
'__ called by GLOBAL GetDesign
'__ calls GLOBAL GetFullFace
'__
Dim i As Integer
Dim s As String
Dim s1 As String
' If ia3 = 0 Then Exit Function
s = GetFullFace(ia1, ia2, ia3, s1)
If Len(s) > 10 Then 'let it bomb out!
gstr = "Yeiks! Too many faces!!!"
End If
'Debug.Print "checking " & s
If InStr(strfacelist, s) Then Exit Function
nfaces = nfaces + 1
ReDim Preserve face(nfaces)
nfacets = nfacets + Len(s)
ReDim Preserve facet(nfacets)
strfacelist = strfacelist & chr13 & s & s & chr13 & s1 & s1
'Debug.Print strfacelist
face(nfaces).sface = Mid$(s & s, Len(s) + 2 - (iconnect - (iconnect = 0)), Len(s))
face(nfaces).nfacets = Len(s)
face(nfaces).isok = True
For i = 1 To Len(s)
face(nfaces).iface(i) = -1
Next
face(nfaces).iface(iconnect) = 0
face(nfaces).iconnect = iconnect
'facets and prev info not nec. here
GetNewFace = nfaces
End Function
Function GetFullFace (ia1 As Integer, ia2 As Integer, ia3 As Integer, srev As String) As String
'__
'__ GLOBAL GetFullFace
'__
'__ parameter ia1 As Integer
'__ parameter ia2 As Integer
'__ parameter ia3 As Integer
'__ parameter srev As String
'__
'__ called by GLOBAL GetNewFace
'__
Dim i As Integer
Dim ia As Integer
Dim s As String
Dim s1 As String
Dim phi As Double
Dim phicut As Double
Dim ch As String * 1
lstsort.Clear
phi = atomsel(ia3).phideg
phicut = 10
For i = 1 To natomsel
If atomsel(i).Enabled Then
If (360 + Abs(atomsel(i).phideg - phi)) Mod 360 <= phicut Then
lstsort.AddItem Format(9999 - atomsel(i).thetadeg, "0000.000")
lstsort.ItemData(lstsort.NewIndex) = i
End If
End If
Next
s = Chr(asc96 + ia1) & Chr(asc96 + ia2)
s1 = Chr(asc96 + ia2) & Chr(asc96 + ia1)
i = 0
'Debug.print ia1, pt_show(0,atomsel(ia1).xyz), atomsel(ia1).phideg, atomsel(ia1).thetadeg
'Debug.print ia2, pt_show(0,atomsel(ia2).xyz), atomsel(ia2).phideg, atomsel(ia2).thetadeg
While i < lstsort.ListCount
ia = lstsort.ItemData(i)
'Debug.print ia, pt_show(0,atomsel(ia).xyz), atomsel(ia).phideg, atomsel(ia).thetadeg
ch = Chr(asc96 + lstsort.ItemData(i)) s = s & ch s1 = ch & s1 i = i + 1 Wend
'Debug.Print s, s1 If phi > 180 Then srev = s GetFullFace = s1 Else srev = s1 GetFullFace = s End If End Function
Miguel wrote:
I have been working on the polyhedral representation and am having a problem.
I have a central point.
I also have 6 distinct points in space, unordered.
I need to construct an octagon
I need to verify that it is valid, in the sense that the central point is on the inside of the faces.
I need to know the orientation of the faces.
Now, I have an implementation that mostly works ... but sometimes fails :-(
I need some fresh ideas on how to solve this problem.
Any help from Jmol users and/or their math buddies would be greatly appreciated.
Miguel
------------------------------------------------------- SF email is sponsored by - The IT Product Guide Read honest & candid reviews on hundreds of IT Products from real users. Discover which products truly live up to the hype. Start reading now. http://ads.osdn.com/?ad_ide95&alloc_id396&op�k _______________________________________________ Jmol-users mailing list [email protected] https://lists.sourceforge.net/lists/listinfo/jmol-users
--
Robert M. Hanson, [EMAIL PROTECTED], 507-646-3107 Professor of Chemistry, St. Olaf College 1520 St. Olaf Ave., Northfield, MN 55057 mailto:[EMAIL PROTECTED] http://www.stolaf.edu/people/hansonr
"Imagination is more important than knowledge." - Albert Einstein
------------------------------------------------------- SF email is sponsored by - The IT Product Guide Read honest & candid reviews on hundreds of IT Products from real users. Discover which products truly live up to the hype. Start reading now. http://ads.osdn.com/?ad_ide95&alloc_id396&op=click _______________________________________________ Jmol-users mailing list [email protected] https://lists.sourceforge.net/lists/listinfo/jmol-users
