0 | module Text.Molfile.Writer.V2000
  1 |
  2 | import Data.Linear.Traverse1
  3 | import Data.SortedMap
  4 | import Data.String
  5 | import Data.String.Builder
  6 | import Syntax.T1
  7 | import Text.Molfile.Types
  8 | import Text.Molfile.Writer.Util
  9 |
 10 | %hide Prelude.(>>)
 11 |
 12 | %default total
 13 |
 14 | %inline
 15 | Interpolation Nat where interpolate = show
 16 |
 17 | %inline
 18 | Interpolation (Fin n) where interpolate = show . S . finToNat
 19 |
 20 | %inline
 21 | Interpolation Radical where interpolate = dispRadical
 22 |
 23 | [IP_ISO] Interpolation Isotope where interpolate = dispIso
 24 |
 25 | fill : Interpolation a => Builder q => Nat -> a -> F1' q
 26 | fill n = putLeftPadded n ' ' . interpolate
 27 |
 28 | pl : Interpolation a => Nat -> a -> String
 29 | pl n = padLeft n ' ' . interpolate
 30 |
 31 | groupMap : List AtomGroup -> GroupMap
 32 | groupMap = SortedMap.fromList . map (\g => (g.nr, (g.lbl, [<])))
 33 |
 34 | dispGrp : (Nat,String,SnocList Nat) -> (String,String,List String)
 35 | dispGrp (x,y,z) = (pl 4 x, y, map (pl 4) z <>> [])
 36 |
 37 | --------------------------------------------------------------------------------
 38 | --          Properties
 39 | --------------------------------------------------------------------------------
 40 |
 41 | record Props where
 42 |   constructor P
 43 |   isos     : List String
 44 |   charges  : List String
 45 |   radicals : List String
 46 |   abbr     : GroupMap
 47 |
 48 | %inline
 49 | prependNonEmpty : String -> List String -> List String
 50 | prependNonEmpty "" = id
 51 | prependNonEmpty s  = (s::)
 52 |
 53 | adjProps : Fin k -> Adj k b (MolAtom' h t c) -> Props -> Props
 54 | adjProps n adj@(A a _) p =
 55 |   let ns := pl 4 n
 56 |       i  := maybe "" (\m => ns ++ pl 4 m) a.elem.mass
 57 |       c  := if a.charge == 0 then "" else ns ++ pl 4 a.charge
 58 |       r  := if a.radical == NoRadical then "" else ns ++ pl 4 a.radical
 59 |
 60 |    in { isos     $= prependNonEmpty i
 61 |       , charges  $= prependNonEmpty c
 62 |       , radicals $= prependNonEmpty r
 63 |       , abbr     $= appendLbl n adj
 64 |       } p
 65 |
 66 | parameters {auto b : Builder q}
 67 |   dispGroup : String -> List String -> F1' q
 68 |   dispGroup p vs = putText p >> fill 3 (length vs) >> putAll vs >> linebreak
 69 |
 70 |   abbreviations : List (String,String,List String) -> F1' q
 71 |   abbreviations ls = T1.do
 72 |     traverse1_ (dispGroup "M  STY" . map (\(x,_) => x ++ " SUP")) (grouped 8 ls)
 73 |     traverse1_ (\(x,y,_) => putTextLn "M  SMT\{x} \{y}") ls
 74 |     for1_ ls $ \(x,_,vs) => traverse1_ (dispGroup "M  SAL\{x}") (grouped 15 vs)
 75 |
 76 |   props : Props -> F1' q
 77 |   props (P is cs rs abbr) =
 78 |     traverse1_ (dispGroup "M  ISO") (grouped 8 is) >>
 79 |     traverse1_ (dispGroup "M  CHG") (grouped 8 cs) >>
 80 |     traverse1_ (dispGroup "M  RAD") (grouped 8 rs) >>
 81 |     abbreviations (dispGrp <$> kvList abbr)
 82 |
 83 | --------------------------------------------------------------------------------
 84 | --          Writer
 85 | --------------------------------------------------------------------------------
 86 |
 87 |   counts : (na,nb : Nat) -> F1' q
 88 |   counts na nb =
 89 |     fill 3 na >> fill 3 nb >> fill 6 NonChiral >> fill 27 V2000 >> linebreak
 90 |
 91 |   coords : Vect 3 Coordinate -> F1' q
 92 |   coords [x,y,z] = fill 10 x >> fill 10 y >> fill 10 z
 93 |
 94 |   %inline atomRem : F1' q
 95 |   atomRem = putTextLn " 0  0  0  0  0  0  0  0  0  0  0  0"
 96 |
 97 |   %inline bondRem : F1' q
 98 |   bondRem = putTextLn "  0  0  0"
 99 |
100 |   -- xxxxx.xxxxyyyyy.yyyyzzzzz.zzzz aaaddcccssshhhbbbvvvHHHrrriiimmmnnneee
101 |   atom : Atom Isotope Charge Coordinates Radical h t c l -> F1' q
102 |   atom (MkAtom a c p _ _ _ _ _) = coords p >> fill @{IP_ISO} 4 a >> atomRem
103 |
104 |   -- 111222tttsssxxxrrrccc
105 |   bond : Edge k MolBond -> F1' q
106 |   bond (E x y $ MkBond True t s) =
107 |    fill 3 x >> fill 3 y >> fill 3 t >> fill 3 s >> bondRem
108 |   bond (E x y $ MkBond False t s) =
109 |    fill 3 y >> fill 3 x >> fill 3 t >> fill 3 s >> bondRem
110 |
111 |   export
112 |   putMol2000 : List (Edge k MolBond) -> MolGraph' h t c -> F1' q
113 |   putMol2000 es (G o g) = T1.do
114 |     counts o (length es)
115 |     traverse1_ (atom . label) g.graph
116 |     traverse1_ bond es
117 |     props $ foldrKV adjProps (P [] [] [] empty) g.graph
118 |