0 | module Text.Molfile.Parser.V3000
  1 |
  2 | import Data.Finite
  3 | import Data.SortedMap
  4 | import Syntax.T1
  5 | import Text.Molfile.Parser.KeyVal
  6 | import Text.Molfile.Parser.Stack
  7 | import Text.Molfile.Parser.Util
  8 | import Text.Molfile.Writer.Util
  9 | import Text.Molfile.Writer.V3000
 10 |
 11 | %default total
 12 |
 13 | --------------------------------------------------------------------------------
 14 | -- Expressions
 15 | --------------------------------------------------------------------------------
 16 |
 17 | ||| Recognizes a V3000 `BEGIN` statement
 18 | export
 19 | beginV3 : (s : String) -> (0 p : NonEmpty (unpack s)) => RExp True
 20 | beginV3 x =
 21 |   mv30 >> spaces >> like "BEGIN" >> spaces >> like x >> dots >> newline
 22 |
 23 | ||| Recognizes a V3000 version line followed by
 24 | ||| `"M  V30 BEGIN CTAB"` and
 25 | export
 26 | v3000 : RExp True
 27 | v3000 = star sdigit >> like "V3000" >> newline >> beginV3 "CTAB"
 28 |
 29 | ||| Recognizes a V3000 `END` statement
 30 | export
 31 | endV3 : (s : String) -> (0 p : NonEmpty (unpack s)) => RExp True
 32 | endV3 x = mv30 >> spaces >> "END" >> spaces >> like x >> spaces >> newline
 33 |
 34 | export
 35 | countsExpr : RExp True
 36 | countsExpr = mv30 >> like "COUNTS" >> spaces
 37 |
 38 | export
 39 | bondExprV3 : RExp True
 40 | bondExprV3 = mv30 >> repeat 4 (spaces >> plus digit)
 41 |
 42 | ||| Expression for V3000 coordinates.
 43 | export
 44 | coordinatesV3 : RExp True
 45 | coordinatesV3 =
 46 |  let pre   := ('-' >> repeatRange 1 4 digit) <|> repeatRange 1 5 digit
 47 |      rem   := '.' >> repeatRange 1 4 digit
 48 |      coord := pre >> opt rem
 49 |   in coord >> plus ' ' >> coord >> plus ' ' >> coord
 50 |
 51 | supLines : RExp True
 52 | supLines = mv30 >> spaces >> decimal >> spaces >> like "SUP" >> keyValRest
 53 |
 54 | --------------------------------------------------------------------------------
 55 | -- State Transitions
 56 | --------------------------------------------------------------------------------
 57 |
 58 | parameters {auto sk : CSTCK q}
 59 |
 60 |   ||| Reads the number of atoms from the given byte string
 61 |   ||| and sets up a new (mutable) graph accodringly.
 62 |   export
 63 |   newV3 : ByteString -> F1 q CST
 64 |   newV3 bs =
 65 |     case cast {to = Nat} (decimal bs) of -- number of atoms
 66 |       0   => writeAs sk.isEmpty True EmptyV3
 67 |       S k => T1.do
 68 |         g <- mgraph k
 69 |         writeAs sk.mgraph g BCount
 70 |
 71 |   ||| Writes the number of bonds to the corresponding field on the stack.
 72 |   export %inline
 73 |   bondsV3 : ByteString -> F1 q CST
 74 |   bondsV3 bs = writeAs sk.count (cast $ decimal bs) CountEnd
 75 |
 76 |   ||| Reads the number of atoms from the given byte string
 77 |   ||| and sets up a new (mutable) graph accodringly.
 78 |   export
 79 |   indexV3 : ByteString -> F1 q CST
 80 |   indexV3 bs = T1.do
 81 |     let ix := cast {to = Nat} (decimal bs)
 82 |     g <- read1 sk.mgraph
 83 |     x <- read1 g.atom
 84 |     m <- read1 g.indices
 85 |     case SortedMap.lookup ix m of
 86 |       Nothing => writeAs g.indices (insert ix x m) Sym3
 87 |       Just _  => failHere {s = CSTCK} (Custom $ MNode ix) CErr
 88 |
 89 |   atomV3 : F1 q CST
 90 |   atomV3 = T1.do
 91 |     mg <- read1 sk.mgraph
 92 |     x  <- read1 mg.atom
 93 |     let x2 := finToNat $ FS x
 94 |     case tryLT x2 of
 95 |       Just0 prf => writeAs mg.atom (natToFinLT x2) Atom3
 96 |       Nothing0  => pure AtomEnd
 97 |
 98 |   massV3 : ByteString -> F1 q CST
 99 |   massV3 bs =
100 |    let x := decimal $ drop 5 bs
101 |     in case refineMassNr (cast x) of
102 |       Nothing => failHere (Custom $ MMass x) CErr
103 |       Just x  => modAtom {elem $= setMass x} >> pure Prop3
104 |
105 |   export
106 |   beginBondV3 : F1 q CST
107 |   beginBondV3 = countdown sk.count BondBegin RestV3
108 |
109 |   export
110 |   checkBondV3 : F1 q CST
111 |   checkBondV3 = T1.do
112 |     mg     <- read1 sk.mgraph
113 |     Just e <- read1 mg.bond | Nothing => pure BondEnd
114 |     linsEdge mg.graph e
115 |     countdown sk.count Bnd3 BondEnd
116 |
117 |   ||| Converts a bytestring into a set of coordinates and
118 |   ||| writes it to the current atom.
119 |   export
120 |   coordsV3 : ByteString -> F1 q CST
121 |   coordsV3 bs =
122 |    let (x,r) := break (SPACE ==) (trimLeft bs)
123 |        (y,z) := break (SPACE ==) (trimLeft r)
124 |     in modAtom {position := [coord x,coord y,coord z]} >> pure AAMap
125 |
126 |   export
127 |   bondV3 : ByteString -> F1 q CST
128 |   bondV3 bs = T1.do
129 |     [_,_,_,tp,a1,a2] <- pure (splitNonEmpty SPACE bs) | _ => checkBondV3
130 |     mg               <- read1 sk.mgraph
131 |     ixs              <- read1 mg.indices
132 |     let Right x      := lkpNode ixs a1   | Left x => failErr x
133 |         Right e      := lkpEdge ixs x a2 | Left x => failErr x
134 |         Right o      := bondOrder tp     | Left x => failErr x
135 |         lbl          := MkBond (x < e.node2) o NoBondStereo
136 |     writeAs mg.bond (Just $ {label := lbl} e) BndProp3
137 |
138 |   export
139 |   sup : ByteString -> F1 q CST
140 |   sup bs = case keyVals bs of
141 |     Left x => getPosition >>= \p => failWith (fromPosition x p) CErr
142 |     Right (I n::S _::I _::t) => case lookupVal "LABEL" t >>= toString of
143 |       Just lbl => case lookupVal "ATOMS" t >>= toNats of
144 |         Just as => T1.do
145 |           mg <- read1 sk.mgraph
146 |           addGroup (cast n) mg lbl as
147 |         Nothing => failHere (Custom MAbbr) CErr
148 |       Nothing => failHere (Custom MAbbr) CErr
149 |     Right p => failHere (Custom MAbbr) CErr
150 |     where
151 |       addGroup : Nat -> MGraph q -> String -> List Nat -> F1 q CST
152 |       addGroup v g l []        = pure SGroup
153 |       addGroup v g l (x :: xs) = T1.do
154 |        is <- read1 g.indices
155 |        let Just n := lookup x is | _ => failHere {sk} (Custom $ MNode x) CErr
156 |        lupdNode g.graph n {label := Just $ G v l}
157 |        addGroup v g l xs
158 |
159 | bondStereoV3 : BondStereo -> Step1 q CSz CSTCK
160 | bondStereoV3 s (_ # t) = let _ # t := modBond {stereo := s} t in BndProp3 # t
161 |
162 | chargeV3 : Charge -> Step1 q CSz CSTCK
163 | chargeV3 c (_ # t) = let _ # t := modAtom {charge := c} t in Prop3 # t
164 |
165 | radicalV3 : Radical -> Step1 q CSz CSTCK
166 | radicalV3 c (_ # t) = let _ # t := modAtom {radical := c} t in Prop3 # t
167 |
168 | ||| Recognizes and drops a fixed number of V3000 lines, increasing
169 | ||| the line count accordingly and setting the column to `6`
170 | ||| (right after the `M  V30` prefix). Constant `mv30` must not be
171 | ||| part of the given regular expression.
172 | export
173 | mv30prefix : Nat -> RExp b -> CST -> (RExp True, Step q CSz CSTCK)
174 | mv30prefix n x = linecol' n 6 (orT $ x >> mv30)
175 |
176 | export
177 | emptyEnd : List (RExp True, Step q CSz CSTCK)
178 | emptyEnd =
179 |  let pre := zeroes >> endV3 "CTAB" >> m_end
180 |   in [newlines' 3 pre CDone, newlines' 3 (pre >> newline) EndMol]
181 |
182 | ||| Recognizers for additional atom properties.
183 | |||
184 | ||| Most of these are currently not handled, and some
185 | ||| are not yet supported.
186 | |||
187 | ||| TODO: At least handle (and possibly ignore) the following props:
188 | |||       `Rgroups`, `ATTCHORD`, `CLASS`, `SEQID`, `SEQNAME`
189 | |||
190 | ||| TODO: CHG, RAD, and CFG (for bonds) should be case-insensitive
191 | export
192 | prop3 : List (RExp True, Step q CSz CSTCK)
193 | prop3 =
194 |      vals (("CHG="++) . interpolate) chargeV3 values
195 |   ++ vals (("RAD="++) . dispRadical) radicalV3 values
196 |   ++ [ conv   (like "MASS=" >> plus digit) massV3
197 |      , cexpr' (like "CFG=" >> oneof ['0','1','2','3']) Prop3
198 |      , conv'  (like "VAL=" >> integer) Prop3
199 |      , conv'  (like "HCOUNT=" >> integer) Prop3
200 |      , cexpr' (like "STBOX=" >> bindigit) Prop3
201 |      , cexpr' (like "INVERT=" >> oneof ['0','1','2']) Prop3
202 |      , cexpr' (like "EXACHG=" >> bindigit) Prop3
203 |      , conv'  (like "SUBST=" >> integer) Prop3
204 |      , cexpr' (like "UNSAT=" >> bindigit) Prop3
205 |      , conv'  (like "RBCNT=" >> integer) Prop3
206 |      , conv'  (like "ATTACHPT=" >> integer) Prop3
207 |      , mv30prefix 1 ('-' >> newline) Prop3
208 |      , newline newline atomV3
209 |      ]
210 |
211 | export
212 | bondProp3 : List (RExp True, Step q CSz CSTCK)
213 | bondProp3 =
214 |      vals (("CFG="++) . dispStereoV3) bondStereoV3 values
215 |   ++ [ cexpr' (like "TOPO=" >> oneof ['0','1','2']) BndProp3
216 |      , conv'  (like "RXCTR=" >> integer) BndProp3
217 |      , cexpr' (like "STBOX=" >> bindigit) BndProp3
218 |      , mv30prefix 1 ('-' >> newline) BndProp3
219 |      , newline newline checkBondV3
220 |      ]
221 |
222 | ||| Recognizes (and currently discards) all remaining lines starting
223 | ||| with `M  V30` until `M  END` is encountered.
224 | export
225 | rest3 : List (RExp True, Step q CSz CSTCK)
226 | rest3 =
227 |   [ conv' m_end CDone
228 |   , newline' (m_end >> newline) EndMol
229 |   , newline' (beginV3 "Sgroup") SGroup
230 |   , newline' (mv30 >> dots >> newline) RestV3
231 |   ]
232 |
233 | export
234 | sgroup : List (RExp True, Step q CSz CSTCK)
235 | sgroup =
236 |   [ newline' (endV3 "Sgroup") RestV3
237 |   , multiline supLines sup
238 |   , newline' (mv30 >> dots >> newline) SGroup
239 |   ]
240 |