'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ACD CHEMBASIC DEMO PROGRAM                                          '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                                     '
' Molecular 3D Editor//LABCHIR.BAS                                    '
'                                                                     '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                                     '
' The utility labels the chirality of all tetrahedral centers         '
'                                                                     '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



CONST TITLE="ChemBasic Molecular Editor // Chirality (all)"
CONST RAD_TO_DEG = 57.29577951308
CONST OUTTBSPACING=50
DIM   outtbb(4) AS INTEGER, Quots AS STRING, WorkPage,OutPage AS OBJECT
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
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LABCHIR.BAS                                                         '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dim struc,asm,at as object, OK as boolean, sa,s as string, i,ia,e,nat as integer
  MAIN="Failed or nothing to do"

  OK=MEDInit
  if OK then OK=GetFirstActiveStructure(struc)
  If Not OK Then Exit Function

  asm=struc.Assembly
  nat=Asm.Count

  for i=1 to nat
    at=Asm.Item(i)
    if at.GetElNumber>1 then
      if struc.AssocAtoms(at).Count=4 then
        s=GetTetrahedralConfiguration(struc,at)
        if s<>"U" then
          at.SetName("("+s+")")
        end if
      end if
    end if
  next i
  WorkPage.Diagrams.Item(1).Depict(Struc)

  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 GetFirstActiveStructure(struct as  object) as  boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dim asm as object
  GetFirstActiveStructure=False
  with WorkPage.Diagrams
    if .Count<1 then exit function
    asm=Assemblies.AddFromCS(.Item(1))
    if asm=NULL then exit function
    struct=asm.Structures.Item(1)
    if struct=NULL then exit function
    GetFirstActiveStructure=True
  end with
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



'   GET TETRAHEDRAL CONFIGURATION


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function GetTetrahedralConfiguration(struct as object,tcenter as object) 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

' Prepare
  config="U"
  GetTetrahedralConfiguration="U"

  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
