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


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



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Main As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' TORSION.BAS                                                         '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim page,diag,asm,struc As Object, storsion As String
Dim na1,na2,na3,na4 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
  storsion=UCase(UserIOBox("Please supply four atoms" ,TITLE ,  ""))

  OK=ParseQueryTorsion(struc,storsion,na1,na2,na3,na4)
  If Not OK Then Exit Function
  OK=GetAndSetDihedral(diag,struc,na1,na2,na3,na4)
  If Not OK Then Exit Function
  Call ClearDiagramLabels(diag)
  Main="Completed."

End Function


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

  ParseQueryTorsion=FALSE

  If s="" Then Exit Function

  ' Extract the numbers
  nf=SubStrings(Trim(s)," :-;,",ss)

  If nf>=4 Then
    na1=Fix(Val(ss(1)))
    na2=Fix(Val(ss(2)))
    na3=Fix(Val(ss(3)))
    na4=Fix(Val(ss(4)))
  Else
    MessageBox("Could not extract four atom numbers 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) And (na4>0) And (na4<=nat)
  OK = OK  And (na1<>na2) And (na2<>na3) And (na3<>na4)
  If Not OK Then
    MessageBox("Bad atom numbers sequence ("+Str(na1)+")("+Str(na2)+")"+"("+Str(na3)+")"+"("+Str(na4)+")", TITLE, MBB_OK + MBI_EXCLAMATION)
    Exit Function
  End if

  ParseQueryTorsion=True

End Function


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

  GetAndSetDihedral=False

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

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

  ' Check if the angle is not bond angle or belongs to a ring
  constr=FALSE
  ringbond=FALSE
  bnd=GetBond(struc,at2,at3)
  If bnd<>NULL Then ringbond=struc.IsRing(bnd)
  If ( (Not IsTorsion(Struc,at1,at2,at3,at4)) 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("Dihedral "+ssr,TITLE, sr)

  ' Set the new value
  If ss<>sr Then

    dr=Val(ss)
    If dr>360.0 Then dr=dr-Fix(dr/360.0)*360.0  ' (there always be a wizard that says 480:)

    If constr Then
      ' The case of improper angle (not torsion or atorsion in ring);
      ' invoke constrained version of 3D-optimization
      If abs((dr/RAD_TO_DEG-r)/r)<0.15 Then softmin=TRUE Else softmin=FALSE
      Call WriteTorsConstr3DCFG(na1,na2,na3,na4,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 torsion
      struc.SetTAngle(at1,at2,at3,at4,dr/RAD_TO_DEG)
    End If

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

  GetAndSetDihedral=True
End Function



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
sub WriteTorsConstr3DCFG(byval a1 as integer,byval a2 as integer,byval a3 as integer,byval a4 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 DIHEDRAL = "+Str(a1)+" "+Str(a2)+" "+Str(a3)+" "+Str(a4)+" "+Str(p0)+" 1000.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 IsTorsion(strmol As  Object, at1 As  Object, at2 As  Object,at3 As  Object, at4 As  Object) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LIB0.BAS PROCEDURE                                                  '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Checks if the three atoms 1-2-3-4 form a torsion                    '
'                                                                     '
' ENTER                                                               '
'     strmol          object of type CB_MOLECULE or CB_STRUCTURE      '
'     at1, at2, at3, at4   atomic objects                             '
' EXIT                                                                '
'     returns TRUE if the atoms do form torsion otherwise FALSE       '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  If strmol.GetType<>CB_MOLECULE And strmol.GetType<>CB_STRUCTURE Then Exit Function
  IsTorsion = IsBonded(strmol,at1,at2) And IsBonded(strmol,at2,at3) And Isbonded(strmol,at3,at4)
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
'@@@@@@