'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ACD CHEMBASIC DEMO PROGRAM                                          '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                                     '
' Molecular 3D Editor//CHIRAL.BAS                                     '
'                                                                     '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                                     '
' The utility checks the cirality of tetrahedral center               '
'                                                                     '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



CONST TITLE="ChemBasic Molecular Editor // Chirality"
CONST STRING_nyimpl="Sorry, this feature is not yet implemented"
CONST RAD_TO_DEG = 57.29577951308
CONST OUTTBSPACING=50
DIM   outtbb(4) AS INTEGER, Quots AS STRING, WorkPage,OutPage AS OBJECT



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Main As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' CHIRAL.BAS                                                          '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dim struc,at as object, s,sat,finmess,aname As String,na1,qq,guess as integer,OK as boolean
  MAIN="Failed or nothing to do"

  OK=True
  OK=MEDInit
  if OK then OK=GetFirstActiveStructure(struc)
  if OK then
    guess=GuessTetrahedron(struc)
    if guess=0 then
      OK=false
      MessageBox("Seems to be no tetrahedral centres here", TITLE, MBB_OK + MBI_EXCLAMATION)
      goto ends
    endif
    s=AskForAtom(guess)
    OK=ParseQueryAtom(struc,s,na1)
    if OK then s=GetTetrahedralConfiguration(struc,na1)
    sat=Trim(struc.Assembly.Item(na1).ElSymbol)+Trim(Str(na1))
    if S="U" then
      finmess="Could not assign the configuration of "+sat
    else
      finmess="The configuration of "+sat+" is "+s
    endif
    qq=MessageBox(finmess + Chr(13) + Chr(13)+ "Label the atom so?", TITLE, MBB_YESNO + MBI_EXCLAMATION)
    if qq = MBR_YES then
      'aname=struc.Assembly.Item(na1).GetName+"("+s+")"
      aname="("+s+")"
      struc.Assembly.Item(na1).SetName(aname)
      RefreshDiagram(ActiveDocument.ActivePage.Diagrams.Item(1),struc)
    end if
  endif
ends:
  if OK then MAIN="Completed."
END FUNCTION
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function MEDInit as Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  MEDInit=True
  WorkPage=ActiveDocument.ActivePage
  OutPage=NULL
  outtbb(1)=200:outtbb(2)=200:outtbb(3)=990:outtbb(4)=OUTTBSPACING
  Quots=Chr(34)
end function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function LabelDiagram(ByVal labtype As String,Diag As Object) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim struc As Object, nl As Integer
  LabelDiagram=False
WITH ActiveDocument.ActivePage.Diagrams
  struc=Assemblies.AddFromCS(diag).Structures.Item(1)
  'supply atomic labels
  nl=SetAtomLabels(labtype,struc)
  'show labelled diagram
  RefreshDiagram(diag,struc)
End WITH
  LabelDiagram=TRUE
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function SetAtomLabels(ByVal labtype As String,Struc As Object) As Integer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim nat As Integer, i As Integer, nl As Integer, x,y,z As Double
Dim l As String, at As Object
WITH Struc.Assembly
    nat=.Count : nl=0
    For i=1 To nat
      at=.Item(i)
      Select Case labtype
        Case "L"
                at.SetName(Str(i))
        Case "U"
                at.SetName("")
        Case "V"
                If (at.GetElNumber>1) Then
                  at.SetName(Str(i))
                Else
                  at.SetName("")
                End If

        Case "E"
                If (at.GetElNumber>1) and (at.GetElNumber<>6) Then
                  at.SetName(Str(i))
                Else
                  at.SetName("")
                End If

    End Select
    Next i
END WITH
SetAtomLabels=nat
End Function 'SetAtomLabels
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function GetFirstActiveStructure(struct as  object) as  boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dim diag,asm as object,OK as boolean
  GetFirstActiveStructure=False

  with ActiveDocument.ActivePage.Diagrams
    if .Count<1 then exit function
    diag=.Item(1)
    asm=Assemblies.AddFromCS(diag)
    if asm=NULL then exit function
    struct=asm.Structures.Item(1)
    if struct=NULL then exit function
    OK=LabelDiagram("L",.Item(1))
    GetFirstActiveStructure=True
  end with

end function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
sub RefreshDiagram(diag as object,strmol as object)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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 Print2_70(s as  String) as  String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  if Len(s)>70 then
    print #2,s : s=""
  end if
  Print2_70=s
end function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
sub AdjustXYZToCenter(strconf as object)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dim x(1),y(1),z(1),x0,y0,z0 as double, i,natoms as integer
  if strconf.GetType<>CB_STRUCTURE AND strconf.GetType<>CB_CONFORMATION then exit sub

  with strconf.Assembly
    natoms=.Count
    Redim x(natoms):Redim y(natoms):Redim z(natoms)
    x0=0.0 : y0=0.0 : z0=0.0
    for i=1 to natoms
      call strconf.GetAtomXYz(.Item(i),x(i),y(i),z(i))
      x0=x0+x(i) : y0=y0+y(i) : z0=z0+z(i)
    next i
    x0=x0/Dbl(natoms): y0=y0/Dbl(natoms) : z0=z0/Dbl(natoms)
    for i=1 to natoms
      x(i)=x(i)-x0 :y(i)=y(i)-y0 : z(i)=z(i)-z0
      call strconf.SetAtomXYz(.Item(i),x(i),y(i),z(i))
    next i
  end with
end sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function AskForAtom(byval guess as integer) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim s As String
  s = UserIOBox("Please supply an atom number" ,TITLE,Str(guess))
  s=UCase(s)
  AskForAtom = s
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ParseQueryAtom(struc as object,byval s As String,na1 as integer) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim i,l,p1,qq,nat As Integer, c,a1,a2 As String, OK as boolean
Dim nsep As Integer,sep(8) As String

  ParseQueryAtom=False
  if s="" then exit function
  s=Trim(s)
  na1=Fix(Val(s))
  nat=struc.Assembly.Count
  OK = (na1>0) And (na1<=nat)
  If Not OK Then
    MessageBox("Bad atom number ("+Str(na1)+")", TITLE, MBB_OK + MBI_EXCLAMATION)
    Exit Function
  else
    ParseQueryAtom=True
  end if
End Function


'   GET TETRAHEDRAL CONFIGURATION


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function GetTetrahedralConfiguration(struct as object,ntcenter as integer) as string
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dim nat,i,j,k,m,ind,sumstr(4),vsumstr(4),tmp,ttmp as integer
dim unit,not_done,end_grow(4) as boolean
dim config,atname(1),ch,ch1,ch2 as string
dim x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4, aa1,bb1,cc1,aa2,bb2,cc2, A,B,C,D,MainFactor as double
dim asm,aflip1(4),aflip2(4),atom,atom1,atom2, hatom1,hatom2,hatom3,hatom4 as object
dim tcenter as object

' Prepare
  config="U"
  GetTetrahedralConfiguration="U"
  tcenter=struct.Assembly.Item(ntcenter)

  if struct.AssocAtoms(tcenter).Count<>4 then         'check for valence
    Exit Function
  end if
  if GetHNumber(struct,tcenter)>1 then exit function   'check for AH2,AH3


  asm=struct.Assembly : nat=asm.Count : Redim atname(nat)
  i=0
  for each atom in asm  'save atomic names if any and set temp name
    i=i+1 : atname(i)=atom.GetName : atom.SetName("00000")
  next atom
  for i=1 to 4
    vsumstr(i)=i
  next i

  not_done=True

' Go


  for i=1 to 4              'create four empty trees on two flippable atoms
    aflip1(i)=Assemblies.AddEmpty
    aflip2(i)=Assemblies.AddEmpty
  next i

  tcenter.SetName("XXXXX")  'mark center as 'busy' atom


  for m=1 to nat            'expand trees and analyze their order
  if not_done then

      not_done=False
      for i=1 to 4

      end_grow(i)=True
      if aflip1(i).Count=0 then
       aflip2(i).Add(struct.AssocAtoms(tcenter).Item(i))
       end_grow(i)=False
       ind=1
      end if
      if aflip1(i).Count>0 and ind=0 then
        for j=1 to aflip1(i).Count
          atom1=aflip1(i).Item(j)

          call SetAtNameChar(atom1,i,"X")
          'atom1.SetName(SetStrChar(i,atom1.GetName,"X"))

          for k=1 to struct.AssocAtoms(atom1).Count
            atom2=struct.AssocAtoms(atom1).Item(k)
            if StrChar(i,atom2.GetName)<>"X" then
              aflip2(i).Add(atom2)
              end_grow(i)=False
            end if
          next k
        next j
      end if
      for k=1 to aflip2(i).Count
        aflip1(i).Add(aflip2(i).Item(k))
      next k
      for k=1 to aflip2(i).Count
        aflip2(i).AtRemove(aflip2(i).Index(aflip2(i).Item(k)))
      next k
      if ind=1 then ind=0

    next i

    for i=1 to 4
      atom1=aflip1(vsumstr(i)).Item(1)
      if StrChar(5,atom1.GetName)="0" then
        sumstr(i)=SumAtomString(StrAround(aflip1(vsumstr(i))))
      end if
    next i

    for i=1 to 4
      for j=i+1 to 4
        atom1=aflip1(vsumstr(i)).Item(1)
        atom2=aflip1(vsumstr(j)).Item(1)
        unit=StrChar(5,atom1.GetName)="0" and StrChar(5,atom2.GetName)="0"
        if unit then
          if sumstr(i)>sumstr(j) then
            tmp=sumstr(i):ttmp=vsumstr(i)
            sumstr(i)=sumstr(j):vsumstr(i)=vsumstr(j)
            sumstr(j)=tmp:vsumstr(j)=ttmp
          end if
        end if
      next j
    next i

    for i=1 to 4
      for j=i+1 to 4
        atom1=aflip1(vsumstr(i)).Item(1)
        atom2=aflip1(vsumstr(j)).Item(1)
        if StrAround(aflip1(vsumstr(i)))=StrAround(aflip1(vsumstr(j))) then
          call SetAtNameChar(atom1,i,"X")
          'atom1.SetName(SetStrChar(5,atom1.GetName,"X"))
          atom2.SetName(SetStrChar(5,atom2.GetName,"X"))
        end if
      next j
    next i

    for i=1 to 4
      atom1=aflip1(vsumstr(i)).Item(1)
      if StrChar(5,atom1.GetName)="0" then  call SetAtNameChar(atom1,5,Str(i))
                                            'atom1.SetName(SetStrChar(5,atom1.GetName,Str(i)))

      if StrChar(5,atom1.GetName)="X" then
       call SetAtNameChar(atom1,5,"0")
       'atom1.SetName(SetStrChar(5,atom1.GetName,"0"))
       not_done=True
      end if
    next i

    for i=1 to 4
      for j=i+1 to 4
        if end_grow(i)=True and end_grow(j)=True then
          if StrChar(5,aflip1(i).Item(1).GetName)="0" And StrChar(5,aflip1(j).Item(1).GetName)="0" then
            goto Define_configuration
          end if
        end if
      next j
    next i

    if end_grow(1)=True and end_grow(2)=True and end_grow(3)=True and end_grow(4)=True then
      goto Define_configuration
    end if

  end if
  next m


'''''''''''''''''''''
Define_configuration:
  for i=1 to 4
    ch=StrChar(5,aflip1(i).Item(1).GetName)
    if ch="0" then
       config="U" : goto Chirality_defined
    end if
    atom=aflip1(i).Item(1)
    if ch="1" then hatom1=atom
    if ch="2" then hatom2=atom
    if ch="3" then hatom3=atom
    if ch="4" then hatom4=atom
  next i
  struct.GetAtomXYZ(hatom1,x1,y1,z1)
  struct.GetAtomXYZ(hatom2,x2,y2,z2)
  struct.GetAtomXYZ(hatom3,x3,y3,z3)
  struct.GetAtomXYZ(hatom4,x4,y4,z4)

  aa1=x3-x2 : bb1=y3-y2 : cc1=z3-z2
  aa2=x4-x2 : bb2=y4-y2 : cc2=z4-z2
  A=bb1*cc2-cc1*bb2
  B=-(aa1*cc2-cc1*aa2)
  C=aa1*bb2-bb1*aa2
  D=-(A*x2+B*y2+C*z2)
  MainFactor=A*x1+B*y1+C*z1+D

  if MainFactor>=0.0001 then config="S"
  if MainFactor<-0.0001 then config="R"



'''''''''''''''''''''
Chirality_defined:
  for i=1 to nat
    asm.Item(i).SetName(atname(i))  'Reset original atomic names
  next i
  GetTetrahedralConfiguration=config
end function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function StrAround(asm as object) as string
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dim na,i,j,tmp,arr(1) as integer, s as string
  s="" : na=asm.Count : Redim arr(na)
  for i=1 to na
    arr(i)=asm.Item(i).GetElNumber
  next i
  for i=1 to na
    for j=i+1 to na
      if i<>j and arr(i)>arr(j) then
        tmp=arr(i) : arr(i)=arr(j) : arr(j)=tmp
      end if
    next j
  next i
  for i=1 to na
    s=s+" "+Str(arr(i))
  next i
  StrAround=s
end function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function SumAtomString(byval strn as string) as integer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dim num,c as string, i,le,sum as integer
  num="" : sum=0 : le=Len(strn)
  for i=1 to le
    c=Mid(strn,i,1)
    if c=" " and i<>1 then
      sum=sum+Int(Val(num))
      num=""
    end if
    if c<>" " then num=num+c
    if i=le   then sum=sum+Int(Val(num))
  next i
  SumAtomString=sum
end function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function StrChar(byval i as integer,byval s as string) as string
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  StrChar=Mid(s,i,1)
end function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function SetStrChar(byval k as integer,byval s as string,byval sym as string) as string
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dim tmp as string,i,le as integer
  tmp=""
  le=Len(s)
  if le<k then
    SetStrChar=s : exit function
  end if
  for i=1 to k-1
    tmp=tmp+Mid(s,i,1)
  next i
  tmp=tmp+sym
  for i=k+1 to le
    tmp=tmp+Mid(s,i,1)
  next i
  SetStrChar=tmp
end function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
sub SetAtNameChar(atom as object,byval i as integer,byval sym as string)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  atom.SetName(SetStrChar(i,atom.GetName,sym))
end sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function GetHNumber(strmol as object,at as object) as integer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dim nh as integer, alist,atom as object
  nh=0
  if strmol.GetType<>CB_MOLECULE AND strmol.GetType<>CB_STRUCTURE then exit function
  alist=strmol.AssocAtoms(at)
  for each atom in alist
    if atom.GetElNumber=1 then nh=nh+1
  next atom
  GetHNumber=nh
end function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function GuessTetrahedron(struc as object) as integer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dim nat,i as integer
  GuessTetrahedron=0
  nat=struc.assembly.count
  for i=1 to nat
    if struc.AssocAtoms(struc.assembly.Item(i)).Count=4 then
      GuessTetrahedron=i : exit function
    end if
  next i
end function