'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ACD CHEMBASIC DEMO PROGRAM                                          '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                                     '
' Molecular 3D Editor//ANGLE.BAS                                      '
'                                                                     '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                                     '
' The utility gets/sets the value of angle formed by 3 atoms          '
'                                                                     '
' NOTE: in contrast to ChemBasic built-in GetVAngle/SetVAngle,        '
'       the utility safely treats the situation of 3 atoms which do   '
'       not form valid bond angle or the atoms belonging to a ring    '
'       (invokes 3D-optimizer if necessary)                           '
'                                                                     '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


CONST TITLE="ChemBasic Molecular Editor // Angle"
CONST RAD_TO_DEG = 57.29577951



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Main As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ANGLE.BAS                                                           '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim page,diag,asm,struc As Object, sangle As String,na1,na2,na3 As Integer,OK As Boolean

  MAIN="Failed or nothing to do!"

  ' Get 1st structure from the curent page
  page=ActiveDocument.ActivePage
  If page.Diagrams.Count<1 Then Exit Function
  diag=page.Diagrams.Item(1)
  asm=Assemblies.AddFromCS(diag)
  If asm=NULL Then Exit Function
  struc=Asm.Structures.Item(1)
  If struc=NULL Then Exit Function

  ' Do the job
  OK=LabelDiagramWithNumbers(diag)
  If Not OK Then Exit Function
  sangle=UCase(UserIOBox("Please supply three atoms" ,TITLE ,  ""))
  OK=ParseQueryAngle(struc,sangle,na1,na2,na3)
  If Not OK Then Exit Function
  OK=GetAndSetAngle(diag,struc,na1,na2,na3)
  If Not OK Then Exit Function
  Call ClearDiagramLabels(diag)
  Main="Completed."

End Function



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ParseQueryAngle(struc As object,ByVal s As String,na1 As Integer,na2 As Integer,na3 As Integer) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Extract (and check for validity) the 3 atom numbers from a string   '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim nat,nf  As Integer, ss(10)As String, OK As Boolean

  ParseQueryAngle=False

  If s="" Then Exit Function

  ' Extract the numbers
  nf=SubStrings(Trim(s)," :-;,",ss)
  If nf>=3 Then
    na1=Fix(Val(ss(1)))
    na2=Fix(Val(ss(2)))
    na3=Fix(Val(ss(3)))
  Else
    MessageBox("Could not extract three atoms from the query", TITLE, MBB_OK + MBI_EXCLAMATION)
    Exit Function
  End If

  ' Check them for validity
  nat=struc.Assembly.Count
  OK = (na1>0) And (na2>0) And (na1<=nat) And (na2<=nat)   And (na3>0) And (na3<=nat)
  OK = OK  And (na1<>na2) And (na2<>na3)
  If Not OK Then
    MessageBox("Bad atom numbers sequence ("+Str(na1)+")("+Str(na2)+")"+"("+Str(na3)+")", TITLE, MBB_OK + MBI_EXCLAMATION)
    Exit Function
  End if

  ParseQueryAngle=True

End Function



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetAndSetAngle(diag As Object,struc As Object,ByVal na1 As Integer,ByVal na2 As Integer,ByVal na3 As Integer) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim i,j,nat As Integer, r,dr As Double, at1,at2,at3,bnd1,bnd2,struc1 As Object
Dim ssr,sr,ss As String, OK,ringbond,constr,softmin As Boolean

  GetAndSetAngle=False

  ' Get the current value
  With struc.Assembly
    at1=.Item(na1)
    at2=.Item(na2)
    at3=.Item(na3)
  End With
  r=Struc.GetVAngle(at1,at2,at3)
  r=RAD_TO_DEG*r

  ' Convert the value to string(s)
  sr=FStr(r,9,4)
  ssr=RTrim(at1.ElSymbol) + Str(na1)+"-" + RTrim(at2.ElSymbol) + Str(na2)+"-"
  ssr=ssr+RTrim(at3.ElSymbol) + Str(na3)
  ssr=ssr+ "   =   " + sr + " deg. New value"

  ' Check if the angle is not bond angle or belongs to a ring
  constr=FALSE
  ringbond=FALSE
  bnd1=GetBond(struc,at1,at2)
  If bnd1<>NULL Then
    bnd2=GetBond(struc,at2,at3)
    If bnd2<>NULL Then ringbond =  struc.IsRing(bnd1) And struc.IsRing(bnd2)
  End If
  If ((Not IsAngle(Struc,at1,at2,at3)) OR ringbond) Then constr=TRUE
  If constr Then
    ssr=ssr+ "[requires 3D-Opt]?"
  Else
    ssr=ssr+ "?"
  End If

  ' Ask for a new value
  sr=Trim(sr)
  ss = UserIOBox("Angle "+ssr,TITLE , sr)

  ' Set the new value
  If ss<>sr Then

    dr=Val(ss)
    If dr<0.0 Then dr=-dr                       ' (there always be a wizard that says -120
    If dr>360.0 Then dr=dr-Fix(dr/360.0)*360.0  '                                      480
    If dr>180.0 Then dr=360.0-dr                '                                      240
    If dr<1.0 Then   dr=1.0                     '                                     or 0 :)
    If constr Then
      ' The case of improper angle (not bond angle or an angle in a ring);
      ' invoke constrained version of 3D-optimization
      If abs((dr/RAD_TO_DEG-r)/r)<0.15 Then softmin=True Else softmin=False
      Call WriteAnglConstr3DCFG(na1,na2,na3,dr,softmin) ' Write CFG-file for optimizer
      struc1=struc.Do3DOptimize(0.1)                    ' Spawn optimizer
      struc=struc1
      Call WriteEmpty3DCFG()                            ' Restore empty CFG for optimizer
    Else
      ' The case of normal bond angle
      struc.SetVAngle(at1,at2,at3,dr/RAD_TO_DEG)
    End If

    ' Show the results
    RefreshDiagram(diag,struc)
    MessageBox("The angle was set to "+Chr(13)+Chr(13)+"       "+FStr(Struc.GetVAngle(at1,at2,at3)*RAD_TO_DEG,9,3)+" deg.", TITLE, MBB_OK + MBI_INFORMATION)
  End If

  GetAndSetAngle=True

End Function



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub WriteAnglConstr3DCFG(ByVal a1 As Integer,ByVal a2 As Integer,ByVal a3 As Integer,ByVal p0 As Double,softmin As Boolean)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Write necessary config for DM3DOPT.DLL                              '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const cfgfile="DM3DOPT.CFG"

  Open cfgfile Access Write As 2
  Print #2, "CONSTRAINT ANGLE = "+Str(a1)+" "+Str(a2)+" "+Str(a3)+" "+Str(p0)+" 10000.0"
  If softmin Then
    Print #2, "OPTIMIZATION = SOFT"
  End If
  Close #2
End Sub



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub WriteEmpty3DCFG()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Write an empty config for DM3DOPT.DLL                               '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const cfgfile="DM3DOPT.CFG"
  Open cfgfile Access Write As 2
  Close #2
End Sub


'***LIBRARY PROCEDURES BEGIN



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub RefreshDiagram(diag As Object,strmol As Object)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LIB0.BAS PROCEDURE                                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Redraws the diagram with a molecule or structure object             '
'                                                                     '
' ENTER                                                               '
'     diag            object of type CS_DIAGRAM                       '
'     strmol          object of type CB_MOLECULE or CB_STRUCTURE      '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim l,t,w,h,w1,h1 As Integer
  diag.GetBound(l,t,w,h)
  diag.Depict(strmol)
  diag.GetBound(w,h,w1,h1)
  diag.SetBound(l,t,w1,h1)
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function LabelDiagramWithNumbers(diag As Object) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LIB0.BAS PROCEDURE                                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Redraws the diagram showing order numbers at atoms                  '
' EXIT                                                                '
'     returns TRUE at success otherwise FALSE                         '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim asm,struc,at As Object, i,nat As Integer
  LabelDiagramWithNumbers=FALSE
  asm=Assemblies.AddFromCS(diag)
  If asm=NULL Then Exit Function
  struc=asm.Structures.Item(1)
  If struc=NULL Then Exit Function
  ' Supply atomic labels
  With asm
    nat=.Count
    For i=1 To nat
      at=.Item(i)
      at.SetName(Str(i))
    Next i
  End With
  ' Show labelled diagram
  RefreshDiagram(diag,struc)
  LabelDiagramWithNumbers=TRUE
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ClearDiagramLabels(diag As Object) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LIB0.BAS PROCEDURE                                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Clears the atomic labels and re-draws diagram                       '
' EXIT                                                                '
'     returns TRUE at success otherwise FALSE                         '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim asm,struc,at As Object, i,nat As Integer
  ClearDiagramLabels=FALSE
  asm=Assemblies.AddFromCS(diag)
  If asm=NULL Then Exit Function
  struc=asm.Structures.Item(1)
  If struc=NULL Then Exit Function
  ' Clear atomic labels
  For Each at In asm
    at.SetName("")
  Next at
  ' Show delabelled diagram
  RefreshDiagram(diag,struc)
  ClearDiagramLabels=TRUE
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function IsBonded(molstructure As Object,at1 As Object, at2 As Object) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LIB0.BAS PROCEDURE                                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Checks if the two atoms in a molecule or structure are bonded       '
'                                                                     '
' ENTER                                                               '
'     molstructure    object of type CB_MOLECULE or CB_STRUCTURE      '
'     at1, at2        atomic objects                                  '
' EXIT                                                                '
'     returns TRUE if the atoms are bonded otherwise FALSE            '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim mchain As Object  'AList object
  IsBonded=False
  mchain=molstructure.MinChain(at1,at2) 'get connecting chain
  If mchain=NULL Then Exit Function     'if any
  If mchain.Count=2 Then IsBonded=True  'and check its length
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function IsAngle(strmol as  object, at1 as  object, at2 as  object,at3 as  object) as boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LIB0.BAS PROCEDURE                                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Checks if the three atoms 1-2-3 form a bond angle                   '
'                                                                     '
' ENTER                                                               '
'     strmol          object of type CB_MOLECULE or CB_STRUCTURE      '
'     at1, at2, at3   atomic objects                                  '
' EXIT                                                                '
'     returns TRUE if the atoms do form angle otherwise FALSE         '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  If strmol.GetType<>CB_MOLECULE And strmol.GetType<>CB_STRUCTURE Then Exit Function
  IsAngle = IsBonded(strmol,at1,at2) And IsBonded(strmol,at2,at3)
End function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetBond(molstructure As Object,at1 As Object, at2 As Object) As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LIB0.BAS PROCEDURE                                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Checks if the two atoms in a molecule or structure are bonded       '
'                                                                     '
' ENTER                                                               '
'     molstructure    object of type CB_MOLECULE or CB_STRUCTURE      '
'     at1, at2        atomic objects                                  '
' EXIT                                                                '
'     returns CB_BOND object if applicable otherwise FALSE            '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim bond,bonds As Object  'BList object
  GetBond=NULL
  bonds=molstructure.AssocBonds(at1) 'get associated bonds for atom 1
  If bonds=NULL Then Exit Function
  For Each bond in bonds
    If (bond.atom1=at2 Or bond.atom2=at2) Then
      GetBond=bond
      Exit Function
    End If
  Next bond
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function SubStrings(ByVal s As String, ByVal sc As String, ss() As String) As Integer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LIB0.BAS PROCEDURE                                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Splits the string onto substrings separated with character          '
' and stores substrings in a string aray                              '
'                                                                     '
' ENTER                                                               '
'     s            source string                                      '
'     sc           separators string (e.g., ".,- " means that         '
'                  '.' ',' '-' and ' ' are possible separators)       '
'                  (CR is always a separator)                         '
' EXIT                                                                '
'     returns number of substrings                                    '
'     ss() is properly re-dimensioned array of sub-strings            '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim i,le,ns As Integer,  c As string, copy As Boolean
  SubStrings=0
  le=Len(s)
  if le<1 Then Exit Function

  copy=False
  ns=0
  For i=1 To le
    c=Mid(s,i,1)
    'If c=sc Then
    If Instr(1,sc,c)>0 Then
    'separator occurred, toggle copying off or simply skip a character
      If copy Then copy=False
    Else
    'treat normal char
      If Not copy Or i=1 Then
        ns=ns+1
        copy=True
        ss(ns)=""
      End If
      ss(ns)=ss(ns)+c
    End If
  Next i
  SubStrings=ns
End Function
'***LIBRARY PROCEDURES END

'@@@@@@