0 | module Text.Molfile.Parser.V2000
  1 |
  2 | import Data.SortedMap
  3 | import Syntax.T1
  4 | import Text.Molfile.Parser.Stack
  5 | import Text.Molfile.Parser.Util
  6 |
  7 | %default total
  8 |
  9 | --------------------------------------------------------------------------------
 10 | -- Expressions
 11 | --------------------------------------------------------------------------------
 12 |
 13 | ||| V2000 Counts line
 14 | export
 15 | v2000 : RExp True
 16 | v2000 = repeat 34 sdigit >> oneof ['V','v'] >> "2000" >> newline
 17 |
 18 | ||| An arbitrary number of spaces and digits followed by a line break.
 19 | export
 20 | sdigits : Nat -> RExp True
 21 | sdigits n = orT $ atleast n sdigit >> newline
 22 |
 23 | ||| Expression recognizing the remainder of an `SMT` entry in
 24 | ||| a v2000 properties block.
 25 | export
 26 | smtExpr : RExp True
 27 | smtExpr = repeat 3 sdigit >> ' ' >> star dot
 28 |
 29 | ||| Expression recognizing the remainder of an `SYT` entry in
 30 | ||| a v2000 properties block.
 31 | export
 32 | styExpr : RExp True
 33 | styExpr = repeat 3 sdigit >> star (repeat 4 sdigit >> ' ' >> repeat 3 upper)
 34 |
 35 | ||| Expression for V2000 coordinates.
 36 | export
 37 | coordinatesV2 : RExp True
 38 | coordinatesV2 =
 39 |   repeat 3 $
 40 |         ("   " >> optmin >> digit          >> rem)
 41 |     <|> ("  "  >> optmin >> repeat 2 digit >> rem)
 42 |     <|> (" "   >> optmin >> repeat 3 digit >> rem)
 43 |     <|> (         optmin >> repeat 4 digit >> rem)
 44 |
 45 |   where
 46 |     optmin, rem : RExp True
 47 |     optmin = ' ' <|> '-' <|> digit
 48 |     rem    = '.' >> repeat 4 digit
 49 |
 50 | --------------------------------------------------------------------------------
 51 | -- State Transitions
 52 | --------------------------------------------------------------------------------
 53 |
 54 | parameters {auto sk : CSTCK q}
 55 |
 56 |   ||| Reads the number of atoms and bonds from a V2000 counts line,
 57 |   ||| and sets up a new (mutable) graph accodringly.
 58 |   export
 59 |   countsV2 : ByteString -> F1 q CST
 60 |   countsV2 bs =
 61 |     case nat (substring 0 3 bs) of -- number of atoms
 62 |       0   => writeAs sk.isEmpty True Prop2
 63 |       S k => T1.do
 64 |         g <- mgraph k
 65 |         write1 sk.count (nat $ substring 3 3 bs)
 66 |         writeAs sk.mgraph g Coords2
 67 |
 68 |   ||| Converts a bytestring into a set of coordinates and
 69 |   ||| writes it to the current atom.
 70 |   export
 71 |   coordsV2 : ByteString -> F1 q CST
 72 |   coordsV2 bs =
 73 |    let x := substring 0  10 bs
 74 |        y := substring 10 10 bs
 75 |        z := substring 20 10 bs
 76 |     in modAtom {position := [coord x,coord y,coord z]} >> pure Sym2
 77 |
 78 |   ||| Finalizes a V2000 atom, increasing the current node and
 79 |   ||| moving to the bond block if all atoms have been processed.
 80 |   export
 81 |   atomV2 : F1 q CST
 82 |   atomV2 = T1.do
 83 |     mg <- read1 sk.mgraph
 84 |     x  <- read1 mg.atom
 85 |     let x2 := finToNat $ FS x
 86 |     case tryLT x2 of
 87 |       Just0 prf => writeAs mg.atom (natToFinLT x2) Coords2
 88 |       Nothing0  => countdown sk.count Bnd2 Prop2
 89 |
 90 |   ||| Sets an atom's charge and finalizes it via `atomV2`.
 91 |   export
 92 |   chargeV2 : F1 q CST
 93 |   chargeV2 =
 94 |     read blockcharge 3 >>= \case
 95 |       Left  x => failErr x
 96 |       Right c => modAtom {charge := c} >> atomV2
 97 |
 98 |   ||| Parses a V2000 bond entry and adds an edge to the graph.
 99 |   export
100 |   bond : F1 q CST
101 |   bond = T1.do
102 |     mg      <- read1 sk.mgraph
103 |     Right x <- read node       3 | Left x => failErr x
104 |     Right e <- read (uedge x)  3 | Left x => failErr x
105 |     Right o <- read bondOrder  3 | Left x => failErr x
106 |     Right s <- read bondStereo 3 | Left x => failErr x
107 |     linsEdge mg.graph ({label := MkBond (x == e.node1) o s} e)
108 |     countdown sk.count Bnd2 Prop2
109 |
110 | --------------------------------------------------------------------------------
111 | -- V2000 properties
112 | --------------------------------------------------------------------------------
113 |
114 |   -- repeats and effect the given number of times before returning
115 |   -- the given result
116 |   repeat : CST -> F1' q -> Nat -> F1 q CST
117 |   repeat res f 0     = pure res
118 |   repeat res f (S k) = T1.do
119 |     f
120 |     Nothing <- read1 sk.error_ | Just _ => pure CErr
121 |     repeat res f k
122 |
123 |   -- reads a three digit natural number and repeats the
124 |   -- given effect the specified number of times
125 |   nx : CST -> F1' q -> F1 q CST
126 |   nx res f = read nat 3 >>= repeat res f
127 |
128 |   -- processes a atom property in the V2000 properties block
129 |   prop :
130 |        (ByteString -> Either ErrPair a)
131 |     -> (a -> MolAtom -> MolAtom)
132 |     -> F1 q CST
133 |   prop rd adj = read1 sk.mgraph >>= nx Prop2 . act
134 |     where
135 |       act : MGraph q -> F1' q
136 |       act mg = T1.do
137 |         Right x <- read node 4 | Left x => fail x
138 |         Right v <- read rd 4   | Left x => fail x
139 |         lupdNode mg.graph x (adj v)
140 |
141 |   chg, iso, rad, sal, sty, smt : F1 q CST
142 |   chg = prop charge $ \c => {charge := c}
143 |   iso = prop massNr $ \m => {elem $= setMass m}
144 |   rad = prop radical $ \r => {radical := r}
145 |
146 |   sal = T1.do
147 |     v <- read nat 4
148 |     nx Prop2 $ T1.do
149 |       mg      <- read1 sk.mgraph
150 |       Right n <- read node 4 | Left x => fail x
151 |       lupdNode mg.graph n {label := Just $ G v ""}
152 |
153 |   sty = nx Prop2 $ T1.do
154 |     n   <- read nat 4
155 |     SUP <- read sgroupType 4 | _ => pure ()
156 |     mod1 sk.groups (insert n "")
157 |
158 |   smt = T1.do
159 |     n <- read nat 5
160 |     s <- remString
161 |     mod1 sk.groups $ \m => case lookup n m of
162 |       Just _  => insert n s m
163 |       Nothing => m
164 |     pure Prop2
165 |
166 | export
167 | line : Nat -> a -> (CSTCK q => F1 q CST) -> (a, Step q CSz CSTCK)
168 | line n x f = (x, Rd $ \(sk # t) => (write1 sk.pos n >> f <* incline 1) t)
169 |
170 | export
171 | prop2 : Steps q CSz CSTCK
172 | prop2 =
173 |   [ line 6 ("M  CHG" >> star ('-' <|> sdigit) >> newline) chg
174 |   , line 6 ("M  ISO" >> star sdigit >> newline) iso
175 |   , line 6 ("M  RAD" >> star sdigit >> newline) rad
176 |   , line 6 ("M  SAL" >> star sdigit >> newline) sal
177 |   , line 6 ("M  STY" >> styExpr >> newline) sty
178 |   , line 6 ("M  SMT " >> smtExpr >> newline) smt
179 |   , newline m_end (end >> pure CDone)
180 |   , newline' (m_end >> newline) EndMol
181 |   , newline' (oneof ['M','V','G','A'] >> "  " >> star dot >> newline) Prop2
182 |   ]
183 |