1 | module CyBy.Draw.Draw

  3 | import CyBy.Draw.Internal.Abbreviations

  4 | import CyBy.Draw.Internal.Atom

  5 | import CyBy.Draw.Internal.CoreDims

  6 | import CyBy.Draw.Internal.DoubleBond

  7 | import CyBy.Draw.Internal.Color

  8 | import CyBy.Draw.Internal.Graph

  9 | import CyBy.Draw.Internal.Label

 10 | import CyBy.Draw.Internal.Role

 11 | import CyBy.Draw.Internal.Settings

 12 | import CyBy.Draw.Internal.Wedge

 13 | import Geom

 14 | import Text.Molfile

 15 | import Text.SVG

 16 | import Text.SVG.Attribute as A

 18 | %default total

 25 | fillCircle : SVGColor -> Point Id -> Double -> SVGNode

 26 | fillCircle c (P x y) rv = circle [cx x.u, cy y.u, r rv.u, fill c, stroke none]

 29 | roundedRect :

 30 |      {auto cd : CoreDims}

 31 |   -> (p1,p2 : Point Id)

 32 |   -> List (SVGAttribute "rect")

 33 |   -> SVGNode

 34 | roundedRect (P a b) (P d e) as =

 35 |   rect $

 36 |        x (min a d).u

 37 |     :: y (min b e).u

 38 |     :: rx cd.radiusAtom.u

 39 |     :: ry cd.radiusAtom.u

 40 |     :: width (abs $ a - d).u

 41 |     :: height (abs $ b - e).u

 42 |     :: as

 45 | fillRect : (cd : CoreDims) => SVGColor -> (p1,p2 : Point Id) -> SVGNode

 46 | fillRect c x y = roundedRect x y [fill c, stroke c]

 49 | outlineRect : (cd : CoreDims) => SVGColor -> (p1,p2 : Point Id) -> SVGNode

 50 | outlineRect c x y = roundedRect x y [fill none, stroke c]

 53 | outlineRectD : (cd : CoreDims) => SVGColor -> (p1,p2 : Point Id) -> SVGNode

 54 | outlineRectD c x y =

 55 |   roundedRect x y [fill none, stroke c, strokeDasharray [5,5]]

 58 | singleLine : SVGColor -> Point Id -> Point Id -> SVGNode

 59 | singleLine c (P x1 y1) (P x2 y2) = path [d [M x1 y1, L x2 y2], stroke c]

 62 | text : (cd : CoreDims) => Text (Point Id) -> SVGNode

 63 | text (T _ "" _ _) = Empty

 64 | text l =

 65 |   let P a b := l.pos

 66 |       P x y := l.textPos

 67 |       -- disable pointer-events, because we do not want text to be

 68 |       -- selectable, nor do we want a different mouse pointer when

 69 |       -- over text nodes.

 70 |       as1   := [A.x x.u, A.y y.u, Style "pointer-events" "none"]

 71 |       as2   := if l.fsize == cd.fontSize then as1 else (fontSize (cast l.fsize).px :: as1)

 72 |    in text1 as2 l.text

 84 | public export

 85 | record Nodes where

 86 |   constructor NS

 87 |   ||| The skeleton of the molecule: All bonds collected in a single `<path>`

 89 |   skeleton : SnocList PathCmd

 91 |   ||| Background shapes mainly use for selected or otherwise highlighted

 93 |   bgShapes : SnocList SVGNode

 95 |   ||| Upward wedges

 96 |   wedges   : SnocList SVGNode

 98 |   ||| All text labels (including charges, implici hydrogens,

100 |   txtLbls : SnocList SVGNode

103 | init : Nodes

104 | init = NS [<] [<] [<] [<]

106 | public export

107 | 0 TNodes : Type

108 | TNodes = Nodes -> Nodes

110 | pathAttrs : SVGColor -> (lw : Double) -> List (SVGAttribute "g")

111 | pathAttrs c lw =

112 |   [stroke c, strokeWidth lw.u, fill none, strokeLinecap Round]

115 | shapeAttrs : SVGColor -> (lw : Double) -> List (SVGAttribute "g")

116 | shapeAttrs c w =

117 |   [stroke c, fill c, strokeWidth w.u, strokeLinecap Round, strokeLinejoin Round]

119 | fontAttrs : (ds : DrawSettings) => List (SVGAttribute "g")

120 | fontAttrs =

121 |   [ stroke none

122 |   , fill ds.textColor

123 |   , fontFamily ds.core.font

124 |   , fontSize (cast ds.core.fontSize).px

125 |   , textAnchor Middle

126 |   ]

128 | group : List (SVGAttribute "g") -> List SVGNode -> SVGNode

129 | group as [] = Empty

130 | group as ns = g as ns

133 | toNodes : (ds : DrawSettings) => TNodes -> List SVGNode

134 | toNodes f =

135 |   let (NS fgp bgs fgs lbls) := f init

136 |    in [ group (shapeAttrs ds.selectBG ds.core.bondBGWidth) (bgs <>> [])

137 |       , group (pathAttrs ds.bondColor ds.core.bondWidth) [path [d (fgp <>> [])]]

138 |       , group (shapeAttrs ds.bondColor ds.core.bondWidth) (fgs <>> [])

139 |       , group (fontAttrs) (lbls <>> [])

140 |       ]

146 | addToBG : SVGNode -> TNodes

147 | addToBG n = {bgShapes $= (:< n)}

149 | addLbl : SVGNode -> TNodes

150 | addLbl n = {txtLbls $= (:< n)}

152 | addCircle : SVGColor -> Point Id -> Double -> TNodes

153 | addCircle c p rv = addToBG (fillCircle c p rv)

155 | line : Point Id -> Point Id -> TNodes

156 | line (P x1 y1) (P x2 y2) = {skeleton $= (:< M x1 y1 :< L x2 y2)}

158 | lineBG : Maybe SVGColor -> Point Id -> Point Id -> TNodes

159 | lineBG Nothing  _ _ ns = ns

160 | lineBG (Just c) x y ns = addToBG (singleLine c x y) ns

162 | wedgeDown : CoreDims => Point Id -> Point Id -> TNodes

163 | wedgeDown p1 p2 = {skeleton $= (<>< Wedge.wedgeDown p1 p2)}

165 | wedgeUp : CoreDims => Point Id -> Point Id -> TNodes

166 | wedgeUp p1 p2 = {wedges $= (:< Wedge.wedgeUp p1 p2 [])}

168 | wedgeBG : CoreDims => Maybe SVGColor -> Point Id -> Point Id -> TNodes

169 | wedgeBG Nothing  _  _  ns = ns

170 | wedgeBG (Just c) p1 p2 ns =

171 |   addToBG (Wedge.wedgeUp p1 p2 [fill c, stroke c]) ns

173 | wave : CoreDims => Point Id -> Point Id -> TNodes

174 | wave p1 p2 = {skeleton $= (<>< Wedge.wave p1 p2)}

176 | waveBG : CoreDims => Maybe SVGColor -> Point Id -> Point Id -> TNodes

177 | waveBG Nothing  _  _  ns = ns

178 | waveBG (Just c) p1 p2 ns =

179 |   addToBG (path [d (Wedge.wave p1 p2), stroke c, fill none]) ns

181 | atmLabels : CoreDims => SVGColor -> AtomLabels (Point Id) -> TNodes

182 | atmLabels c ls = addLbl (group [fill c] (text <$> labels ls))

184 | labelBG : SVGColor -> Text (Point Id) -> TNodes

185 | labelBG c l =

186 |   case radius l of

187 |     Nothing => id

188 |     Just r  => addCircle c l.pos r

190 | abbrBG : CoreDims => SVGColor -> Text (Point Id) -> TNodes

191 | abbrBG c t ns =

192 |   let Just (p1,p2) := corners (bounds t) | Nothing => ns

193 |    in addToBG (fillRect c p1 p2) ns

200 | background :

201 |      {0 a : Type}

202 |   -> {auto cst : Cast a Role}

203 |   -> {auto s   : DrawSettings}

204 |   -> (dflt     : Maybe SVGColor)

205 |   -> a

206 |   -> Maybe SVGColor

207 | background deflt v =

208 |   if      is New v then Just s.newBG

209 |   else if is Origin v then Just s.originBG

210 |   else if is Hover v then Just s.hoverBG

211 |   else if is Selected v then Just s.selectBG

212 |   else if is Highlight v then Just s.highlightBG

213 |   else deflt

219 | parameters {auto s : DrawSettings}

220 |            {k      : _}

221 |            (g      : CDIGraph k)

223 |   abbrText : AbbrPos -> String -> String

224 |   abbrText AE t = t

225 |   abbrText AW t = reverseLabel t s.abbreviations

226 |   

227 |   export

228 |   label : Fin k -> Label

229 |   label x =

230 |     case visible g x of

231 |       False => Hidden

232 |       True  => case labelVisible s.showC g x of

233 |         False => NoLabel (pointAt g x)

234 |         True  => case group (lab g x) of

235 |           Just (G _ a) =>

236 |             let ap := abbrPos g x

237 |                 p  := pointAt g x

238 |              in Abbreviation p $ abbrTextPos ap p (text False $ abbrText ap a)

239 |           Nothing         =>

240 |             let atm := atom $ lab g x

241 |                 sym := text False (symbol atm.elem.elem)

242 |                 ch  := text True (chargeLabel atm.charge)

243 |                 mn  := text True (massLabel atm.elem.mass)

244 |                 hl  := text False (hlabel atm.hydrogen)

245 |                 hc  := text True (hsubscript atm.hydrogen)

246 |              in Explicit $ setPositions (hpos g x) (pointId atm) (AL sym ch mn hl hc)

248 |   export

249 |   labels : Labels k

250 |   labels = generate k label

252 |   atomBG : Labels k -> Fin k -> TNodes

253 |   atomBG ls x ns =

254 |     let atm  := lab g x

255 |         dflt := if isInvalid atm.atom.type then Just s.errorBG else Nothing

256 |      in case background dflt atm of

257 |           Nothing => ns

258 |           Just c  => case at ls x of

259 |             Abbreviation _ abbr => abbrBG c abbr ns

260 |             Explicit l          => foldl (flip $ labelBG c) ns (labels l)

261 |             NoLabel p           => addCircle c p s.core.radiusAtom ns

262 |             Hidden              => ns

264 |   drawAtom : Labels k -> Nodes -> Fin k -> Nodes

265 |   drawAtom ls ns x =

266 |     let ns2 := atomBG ls x ns

267 |      in case at ls x of

268 |           Abbreviation _ abbr => addLbl (text abbr) ns2

269 |           Explicit l => atmLabels (s.elemColor (cast $ lab g x)) l ns2

270 |           NoLabel p  => ns2

271 |           Hidden     => ns2

273 |   snglBond : Maybe SVGColor -> Point Id -> Point Id -> BondStereo -> TNodes

274 |   snglBond c x y Up     ns = wedgeUp x y $ wedgeBG c x y ns

275 |   snglBond c x y Either ns = wave x y $ waveBG c x y ns

276 |   snglBond c x y Down   ns = wedgeDown x y $ wedgeBG c x y ns

277 |   snglBond c x y _      ns = line x y $ lineBG c x y ns

279 |   dblBond : Maybe SVGColor -> Fin k -> Fin k -> Point Id -> Point Id -> TNodes

280 |   dblBond c x y px py ns =

281 |     let [a,b,d,e] := dblBond g x y (pointAt g x) (pointAt g y) px py

282 |      in line a b . line d e . lineBG c a b $ lineBG c d e ns

284 |   trplBond : Maybe SVGColor -> Point Id -> Point Id -> TNodes

285 |   trplBond c x y ns =

286 |     let r     := 0.8 * s.core.radiusAtom

287 |         (a,b) := parallelLine r True x y

288 |         (d,e) := parallelLine r False x y

289 |      in line x y . line a b . line d e .

290 |         lineBG c x y . lineBG c a b $ lineBG c d e ns

292 |   addBond :

293 |        MolBond

294 |     -> Maybe SVGColor

295 |     -> (x,y : Fin k)

296 |     -> (px,py : Point Id)

297 |     -> TNodes

298 |   addBond (MkBond True  Single st) c x y px py = snglBond c px py st

299 |   addBond (MkBond False Single st) c x y px py = snglBond c py px st

300 |   addBond (MkBond _     Dbl    _ ) c x y px py = dblBond c x y px py

301 |   addBond (MkBond _     Triple _ ) c x y px py = trplBond c px py

303 |   drawBond : Labels k -> Nodes -> Edge k CDBond -> Nodes

304 |   drawBond ls ns (E x y b) =

305 |     let c  := background Nothing b

306 |         px := pointAt g x

307 |         py := pointAt g y

308 |         lx := at ls x

309 |         ly := at ls y

310 |         Just (qx,qy) := endpoints px py lx ly | Nothing => ns

311 |      in addBond b.molBond c x y qx qy ns

314 | drawMolecule : DrawSettings => CDGraph -> List SVGNode

315 | drawMolecule (G o g) = toNodes (scene $ labels g)

316 |   where

317 |     scene : Labels o -> TNodes

318 |     scene ls ns =

319 |       foldl (drawAtom g ls) (foldl (drawBond g ls) ns (edges g)) (nodes g)

326 | rotateTemplScene : DrawSettings => Point Mol -> Point Mol -> List SVGNode

327 | rotateTemplScene @{ds} o m =

328 |   [ fillCircle ds.hoverBG (convert o) ds.core.radiusAtom

329 |   , singleLine ds.hoverBG (convert o) (convert m)

330 |   ]