'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ACD CHEMBASIC DEMO PROGRAM                                          '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                                     '
' Molecular 3D Editor//DISTANCE.BAS                                   '
'                                                                     '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                                     '
' The utility gets/sets the distance between 2 atoms                  '
'                                                                     '
' NOTE: in contrast to ChemBasic built-in GetDist/SetDist,            '
'       the utility safely treats the situation of 2 nonbonded atoms  '
'       or the atoms belonging to a ring (invokes 3D-optimizer if     '
'       necessary)                                                    '
'                                                                     '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


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




'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Main As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DISTANCE.BAS                                                        '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim page,diag,asm,struc As Object, sbond As String,na1,na2 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
  sbond=UCase(UserIOBox("Please supply two atoms" ,TITLE ,  ""))
  OK=ParseQueryBond(struc,sbond,na1,na2)

  If Not OK Then Exit Function
  OK=GetAndSetDistance(diag,struc,na1,na2)
  If Not OK Then Exit Function
  Call ClearDiagramLabels(diag)
  Main="Completed."

End Function



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

  ParseQueryBond=False

  If s="" Then Exit Function

  ' Extract the numbers
  nf=SubStrings(Trim(s)," :-;,",ss)
  If nf>=2 Then
    na1=Fix(Val(ss(1)))
    na2=Fix(Val(ss(2)))
  Else
    MessageBox("Could not extract two 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 (na1<>na2)
  If Not OK Then
    MessageBox("Bad atom numbers sequence ("+Str(na1)+")("+Str(na2)+")", TITLE, MBB_OK + MBI_EXCLAMATION)
    Exit Function
  End if

  ParseQueryBond=True

End Function



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

  GetAndSetDistance=False

  ' Get the current value
  With struc.Assembly
    at1=.Item(na1)
    at2=.Item(na2)
  End With
  r=Struc.GetDist(at1,at2)

  ' Convert the value to string(s)
  sr=FStr(r,10,5)
  ssr=RTrim(at1.ElSymbol) + Str(na1)+"--" + RTrim(at2.ElSymbol) + Str(na2) + "   =   " + sr + " A. New value"

  ' Check if the angle is not bond angle or belongs to a ring
  constr=FALSE
  ringbond=FALSE

  bnd=GetBond(struc,at1, at2)
  If bnd<>NULL Then ringbond=struc.IsRing(bnd)
  If ( (bnd=NULL) OR ringbond) Then constr=TRUE
  If constr Then
      ssr=ssr+ " [will invoke 3D-Optimization] ?"
  Else
      ssr=ssr+ "?"
  End If

  ' Ask for a new value
  sr=Trim(sr)
  ss = UserIOBox("Distance "+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 -1.54
    If dr<0.01 Then dr=0.01                     '                                      or 0 :)

    If constr Then
      ' The case of nonbonded or ring atoms
      ' invoke constrained version of 3D-optimization
      If Abs((dr-r)/r)<0.15 then softmin=TRUE else softmin=FALSE
      Call WriteDistConstr3DCFG(na1,na2,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.SetBLen(at1,at2,dr)
    End If

    ' Show the results
    RefreshDiagram(diag,struc)
    MessageBox("The distance was set to "+Chr(13)+Chr(13)+"        "+FStr(Struc.GetDist(at1,at2),10,5)+" A", TITLE, MBB_OK + MBI_INFORMATION)
  End If

  GetAndSetDistance=True

End Function



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
sub WriteDistConstr3DCFG(ByVal a1 As Integer,ByVal a2 As Integer,ByVal r0 As Double,softmin As Boolean)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Write necessary config for DM3DOPT.DLL                              '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const cfgfile="DM3DOPT.CFG"
  Open cfgfile access write as 2
  Print #2, "CONSTRAINT DISTANCE = "+Str(a1)+" "+Str(a2)+" "+Str(r0)+" 50000.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 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

'@@@@@@
