0 | module CyBy.Draw

  2 | import CyBy.Draw.Internal.Color

  3 | import CyBy.Draw.Internal.Label

  4 | import CyBy.UI.CSS.Classes

  5 | import CyBy.UI.HTML

  6 | import Data.Finite

  8 | import Data.List

  9 | import Geom

 10 | import Geom.Gen2D.Debug

 11 | import Text.HTML.DomID

 12 | import Text.HTML.Select

 13 | import Text.SVG

 14 | import Text.Show.Pretty

 15 | import Web.Async

 16 | import Web.Internal.Types

 18 | import public CyBy.Draw.Draw

 19 | import public CyBy.Draw.Event

 20 | import public CyBy.Draw.I18n as I

 21 | import public CyBy.Draw.Internal.Abbreviations

 22 | import public CyBy.Draw.Internal.Atom

 23 | import public CyBy.Draw.Internal.CoreDims

 24 | import public CyBy.Draw.Internal.Graph

 25 | import public CyBy.Draw.Internal.Ring

 26 | import public CyBy.Draw.Internal.Role

 27 | import public CyBy.Draw.Internal.Settings

 28 | import public CyBy.Draw.MoleculeCanvas

 29 | import public CyBy.Draw.PeriodicTableCanvas

 30 | import public Text.Molfile

 32 | %default total

 33 | %hide Data.Linear.(.)

 34 | %hide Text.SVG.Types.Path.t

 41 | color : ColorScheme -> Elem -> SVGColor

 42 | color Black  = const black

 43 | color CyBy   = basicColors

 44 | color Groups = groupColors

 45 | color CPK    = cpkColor

 46 | color CDK    = cdkColor

 47 | color JMol   = jmolColor

 48 | color PyMol  = pymolColor

 51 | molToClipboard : HasIO io => CDGraph -> io ()

 52 | molToClipboard = toClipboard . writeMolfile . toMolfile

 54 | fromClipboard : Sink DrawEvent => DrawLocal => Act ()

 55 | fromClipboard =

 56 |   readFromClipboard >>= \s =>

 57 |     case readMolfileE s of

 58 |       Left x  => case smilesToMol s of

 59 |         Left  _ => readErr x

 60 |         Right m => sink (Event.SetTempl $ initGraph m.graph)

 61 |       Right g => sink (Event.SetTempl g)

 64 | storeSVG : String -> Act ()

 65 | storeSVG s =

 66 |   use1 (blob s "image/svg+xml" >>= blobURL) $ \u => Prelude.do

 67 |     e  <- createElement "a"

 68 |     setAttribute e "href" (cast u)

 69 |     setAttribute e "download" "cyby_draw_img.svg"

 70 |     he <- jsCast {t = HTMLElement} "storeSVG:<a> conversion" e

 71 |     click he

 78 | public export

 79 | record DrawEnv where

 80 |   [noHints]

 81 |   constructor DE

 82 |   pre          : String

 83 |   {auto sets   : DrawSettings}

 84 |   {auto events : Sink DrawEvent}

 92 | public export

 93 | record Extension where

 94 |   [noHints]

 95 |   constructor E

 96 |   doExport : DrawSettings => DrawState -> Act ()

 98 |   ||| Creats additional buttons to be displayed in the top bar

101 |   buttons  : DrawEnv -> DrawState -> Act HTMLNodes

103 |   ||| Make adjustments to the additional top bar buttons 

104 |   adjust   : DrawEnv -> DrawEvent -> DrawState -> Act ()

110 | down : MouseInfo -> Maybe DrawEvent

111 | down mi = case mi.button of

112 |   0 => Just LeftDown

113 |   1 => Just MiddleDown

114 |   _ => Nothing

116 | up : MouseInfo -> Maybe DrawEvent

117 | up mi = case mi.button of

118 |   0 => Just LeftUp

119 |   1 => Just MiddleUp

120 |   _ => Nothing

122 | move : MouseInfo -> Maybe DrawEvent

123 | move x = Just $ Move x.offsetX x.offsetY

125 | wheel : WheelInfo -> Maybe DrawEvent

126 | wheel wi =

127 |   if wi.deltaY < 0 then Just (ZoomIn True)

128 |      else if wi.deltaY > 0 then Just (ZoomOut True)

129 |      else Nothing

135 | moleculeCanvas : String -> Ref Div

136 | moleculeCanvas pre = Id "\{pre}-molecule-canvas"

138 | sketcherDiv : String -> Ref Div

139 | sketcherDiv pre = Id "\{pre}-sketcher-div"

141 | elemsID : String -> Ref Div

142 | elemsID pre = Id "\{pre}-elems"

145 | infoID : String -> Ref Div

146 | infoID pre = Id "\{pre}-draw-info"

148 | detailsID : String -> Ref Section

149 | detailsID pre = Id "\{pre}-draw-details"

151 | utilsID : String -> Ref Div

152 | utilsID pre = Id "\{pre}-utils"

154 | templatesID : String -> Ref Div

155 | templatesID pre = Id "\{pre}-templates"

158 | expButton : String -> Ref Tag.Button

159 | expButton pre = Id "\{pre}-exp-button"

164 |   

165 | abbrActive : DrawState -> Attribute t

166 | abbrActive s =

167 |   case s.mode of

168 |     SetAbbr _ => active True

169 |     _         => active False

171 | drawing : MolBond -> DrawState -> Bool

172 | drawing b s =

173 |   (s.mode == Draw || s.mode == Drawing Nothing) &&

174 |   (s.bond == b)

176 | setting : Elem -> DrawState -> Bool

177 | setting el s = s.mode == SetAtom (cast el)

179 | %inline fromStereo : BondStereo -> MolBond

180 | fromStereo = MkBond True Single

182 | disable : Bool -> HTMLNode -> HTMLNode

183 | disable b = withAttribute (disabled b)

185 | minZoom : (s : DrawSettings) => AffineTransformation -> Bool

186 | minZoom (AT tf _) = tf.scale <= s.minZoom

188 | maxZoom : (s : DrawSettings) => AffineTransformation -> Bool

189 | maxZoom (AT tf _) = tf.scale >= s.maxZoom

191 | pse : Mode -> Bool

192 | pse (PTable _)  = True

193 | pse (SetAtom i) = all (i.elem /=) (the (List Elem) [C,O,N,F,P,S,Cl,Br])

194 | pse _           = False

196 | detail : String -> HTMLNode -> HTMLNode

197 | detail ttl n = li [] [label [] [Text ttl], n]

199 | currAbbr : Mode -> Maybe String

200 | currAbbr (SetAbbr a) = Just a.label

201 | currAbbr _           = Nothing

203 | parameters {auto de : Sink DrawEvent}

204 |            {auto lc : DrawLocal}

206 |   elements : MolAtomAT -> HTMLNode

207 |   elements a =

208 |     selectFromListBy' values (a.elem.elem ==) symbol ChgElem [title setElement]

210 |   charges : MolAtomAT -> HTMLNode

211 |   charges a =

212 |     selectFromListBy' chs (a.charge ==) (show . value) ChgCharge

213 |       [title setCharge]

214 |     where

215 |       chs : List Charge

216 |       chs = mapMaybe refineCharge [(-8) .. 8]

218 |   massNrs : MolAtomAT -> HTMLNode

219 |   massNrs a =

220 |     selectFromListBy' (masses a.elem.elem) (a.elem.mass ==) dispMass ChgMass

221 |       [title setMass]

222 |     where

223 |       dispMass : Maybe MassNr -> String

224 |       dispMass Nothing  = mix

225 |       dispMass (Just m) = show m.value

227 |   icon :

228 |        Classes

229 |     -> DrawEvent

230 |     -> (active : Bool)

231 |     -> (title : String)

232 |     -> HTMLNode

233 |     -> HTMLNode

234 |   icon cs ev a ttl child =

235 |     button

236 |       [classes (icon::cs),active a,onClick ev,title ttl]

237 |       [child]

239 |   abbrs : (ds : DrawSettings) => (pre : String) -> DrawState -> HTMLNode

240 |   abbrs pre s =

241 |     selectFromListBy'

242 |       (Nothing :: map Just ds.abbreviations)

243 |       (\v => currAbbr s.mode == map label v)

244 |       (maybe abbreviations label)

245 |       (maybe Redraw SelAbbr)

246 |       [abbrActive s]

248 |   bondIcon : MolBond -> String -> DrawState -> HTMLNode -> HTMLNode

249 |   bondIcon b title s = icon [] (SetBond b) (drawing b s) title

251 |   utils :

252 |        {auto ds : DrawSettings}

253 |     -> (pre     : String)

254 |     -> (topadd  : HTMLNodes)

255 |     -> DrawState

256 |     -> HTMLNode

257 |   utils {ds} pre topadd s =

258 |     div

259 |       [ Id $ utilsID pre, class drawUtils ] $

260 |       [ icon [] SelectMode (s.mode == Select) selectTxt select

261 |       , icon [] EraseMode (s.mode == Erase) eraseTxt erase

262 |       , icon [] Clear False clearTxt trash

263 |       , nodeSep

264 |       , disable (s.undos == []) $ icon [] Undo False undoTxt undo

265 |       , disable (s.redos == []) $ icon [] Redo False redoTxt redo

266 |       , nodeSep

267 |       , icon [] Center False centerTxt center

268 |       , disable (maxZoom s.transform) $ icon [] (ZoomIn False) False zoomInTxt zoomIn

269 |       , disable (minZoom s.transform) $ icon [] (ZoomOut False) False zoomOutTxt zoomOut

270 |       , nodeSep

271 |       , bondIcon (cast Single) singleBnd s single

272 |       , bondIcon (fromStereo Up) singleUp s bondUp

273 |       , bondIcon (fromStereo Down) singleDown s bondDown

274 |       , bondIcon (fromStereo Either) singleEither s bondEither

275 |       , bondIcon (cast Types.Dbl) doubleBond s double

276 |       , bondIcon (cast Triple) tripleBond s triple

277 |       , nodeSep

278 |       ] ++ topadd

280 |   template : CDGraph -> String -> DrawState -> HTMLNode -> HTMLNode

281 |   template g nm s = icon [] (SetTempl g) (s.mode == SetTempl g) nm 

283 |   elemIcon : DrawState -> String -> Elem -> HTMLNode

284 |   elemIcon s t e = icon [elem] (SetElem e) (setting e s) t (Text $ symbol e)

286 |   elems pre s =

287 |     div

288 |       [ Id $ elemsID pre, class drawElems ]

289 |       [ elemIcon s boron B

290 |       , elemIcon s carbon C

291 |       , elemIcon s oxygen O

292 |       , elemIcon s nitrogen N

293 |       , elemIcon s fluorine F

294 |       , elemIcon s phosphorous P

295 |       , elemIcon s sulfur S

296 |       , elemIcon s chlorine Cl

297 |       , elemIcon s bromine Br

298 |       , nodeSep

299 |       , icon [pseIcon] StartPSE (pse s.mode) pseLong (Text pse)

300 |       ]

302 |   detailItems : (pre : String) -> DrawState -> HTMLNodes

303 |   detailItems pre s =

304 |     case selectedNodes s.imol False of

305 |       [n] =>

306 |         let atm     := atom $ lab s.imol n

307 |             tpe     := atm.type.name

308 |             [x,y,_] := atm.position

309 |             cx      := dispCoordShort x

310 |             cy      := dispCoordShort y

311 |          in [ detail element  $ elements atm

312 |             , detail isotope  $ massNrs atm

313 |             , detail charge   $ charges atm

314 |             , detail atomType $ div [] [Text tpe]

315 |             , detail xcoord   $ div [] [Text cx]

316 |             , detail ycoord   $ div [] [Text cy]

317 |             ]

318 |       _   => case selectedEdges s.imol of

319 |         [(x,y)] =>

320 |           let px := point $ position $ atom $ lab s.imol x

321 |               py := point $ position $ atom $ lab s.imol y

322 |               d  := printDouble 3 $ distance px py

323 |               a  := angleOrZero (px - py)

324 |               a' := printDouble (S Z) $ toDegree $ if a >= Angle.pi then (a - Angle.pi) else a

325 |            in [ detail "Length"   $ div [] [Text "\{d} Å"]

326 |               , detail "Angle"    $ div [] [Text "\{a'}°"]

327 |               ]

328 |         _       => []

330 |   details : (pre : String) -> DrawState -> HTMLNode

331 |   details pre s =

332 |     section

333 |       [ Id $ detailsID pre, class drawDetails ]

334 |       [ header [] [label [] [Text detailsTxt]]

335 |       , ul [] (separate $ detailItems pre s)

336 |       ]

338 |   templates : DrawSettings => (pre : String) -> DrawState -> HTMLNode

339 |   templates pre s =

340 |     div

341 |       [ Id $ templatesID pre, class drawTemplates ]

342 |       [ template phenyl benzene s benzene

343 |       , template (ring 6) I.cyclohexane s cyclohexane

344 |       , template (ring 5) I.cyclopentane s cyclopentane

345 |       , template (ring 3) I.cyclopropane s cyclopropane

346 |       , template (ring 4) I.cyclobutane s cyclobutane

347 |       , template (ring 7) I.cycloheptane s cycloheptane

348 |       , template (ring 8) I.cyclooctane s cyclooctane

349 |       , nodeSep

350 |       , abbrs pre s

351 |       ]

353 |   export

354 |   sketcher :

355 |        {auto ds : DrawSettings}

356 |     -> (pre     : String)

357 |     -> (topadd  : HTMLNodes)

358 |     -> DrawState

359 |     -> HTMLNode

360 |   sketcher pre topadd s =

361 |     div

362 |       [ class sketcher, Id $ sketcherDiv pre ]

363 |       [ utils pre topadd s

364 |       , elems pre s

365 |       , div [class drawInfo, Id $ infoID pre] [details pre s]

366 |       , div

367 |           [ class moleculeCanvas

368 |           , Id $ moleculeCanvas pre

369 |           , Event $ MouseMove move

370 |           , Event $ MouseDown down

371 |           , Event $ MouseUp up

372 |           , Event_ True False $ Wheel wheel

373 |           , Event_ True False $ KeyDown (Just . KeyDown . key)

374 |           , Event_ True False $ KeyUp (Just . KeyUp . key)

375 |           , onMouseEnter Draw.Event.Focus

376 |           , onMouseLeave Draw.Event.Blur

377 |           , onDblClick Expand

378 |           , onResize (\r => Resize r.height r.width)

379 |           , Str "tabindex" "1"

380 |           , active s.isActive

381 |           ]

382 |           [Raw s.curSVG]

383 |       , templates pre s

384 |       ]

387 | cybyDrawBtn : Sink e => String -> e -> Attributes Tag.Button -> HTMLNode

388 | cybyDrawBtn s e as = button (onClick e :: as) [Text s]

391 | expBtn : DrawEnv => String -> DrawState -> HTMLNode

392 | expBtn @{DE pre} txt s =

393 |   cybyDrawBtn txt SVG  [Id $ expButton pre, disabled $ emptyGraph s]

399 | parameters {auto ds : DrawSettings}

400 |            {auto se : Sink DrawEvent}

401 |            {auto lc : DrawLocal}

402 |            {auto ex : Extension}

403 |            (pre : String)

405 |   selectCursor : DrawState -> Act ()

406 |   selectCursor s =

407 |     attr (moleculeCanvas pre) $ dragMode $ case s.mode of

408 |       Dragging _    => Dragging

409 |       Rotating _    => Rotating

410 |       RotTempl _ _  => Rotating

411 |       Translating _ => Dragging

412 |       _             => applyWhenSel s Dragging Rotating None

414 |   displayST : (force : Bool) -> DrawState -> Act ()

415 |   displayST force s = Prelude.do

416 |     when s.isActive $ focus (moleculeCanvas pre)

417 |     when (force || s.curSVG /= s.prevSVG) $

418 |       child (moleculeCanvas pre) (Raw s.curSVG)

420 |   adjustBars : DrawState -> Act ()

421 |   adjustBars s = Prelude.do

422 |     topadd <- ex.buttons (DE pre) s

423 |     replace (utilsID pre) (utils pre topadd s)

424 |     replace (templatesID pre) (templates pre s)

425 |     replace (elemsID pre) (elems pre s)

426 |     replace (detailsID pre) (details pre s)

428 |   dispKeyDown : String -> DrawState -> Act ()

429 |   dispKeyDown "Escape" s = adjustBars s

430 |   dispKeyDown "c" s =

431 |     when (s.modifier == Ctrl) $

432 |       let g := selectedSubgraph True s.mol

433 |        in when (g.order > 0) (molToClipboard g >> copied)

434 |   dispKeyDown "x" s =

435 |     when (s.modifier == Ctrl) $

436 |       let g := selectedSubgraph False s.mol

437 |        in when (g.order > 0) (molToClipboard g >> copied)

438 |   dispKeyDown "v"    s =

439 |     -- we need to read from the clipboard in a new fiber, because the result

440 |     -- will be written to the sink of `DrawEvent`s, which we are currently

441 |     -- processing

442 |     when (s.modifier == Ctrl) (ignore $ start fromClipboard)

443 |   dispKeyDown "Ctrl" s = selectCursor s

444 |   dispKeyDown _      s = pure ()

446 |   %inline

447 |   doFocus : Act ()

448 |   doFocus =

449 |     focus (moleculeCanvas pre) >> attr (moleculeCanvas pre) (active True)

451 |   %inline

452 |   doBlur : Act ()

453 |   doBlur =

454 |     blur (moleculeCanvas pre) >> attr (moleculeCanvas pre) (active False)

456 |   displayEv : DrawEvent -> DrawState -> Act ()

457 |   displayEv Focus            s = doFocus

458 |   displayEv Blur             s = doBlur

459 |   displayEv (KeyDown k)      s = dispKeyDown k s

460 |   displayEv (KeyUp _)        s = adjustBars s

461 |   displayEv (SetElem _)      s = adjustBars s

462 |   displayEv (SelAbbr _)      s = adjustBars s

463 |   displayEv (SetBond _)      s = adjustBars s

464 |   displayEv (SetTempl _)     s = adjustBars s

465 |   displayEv (Load _)         s = adjustBars s

466 |   displayEv SelectMode       s = adjustBars s

467 |   displayEv EraseMode        s = adjustBars s

468 |   displayEv (ChgElem _)      s = adjustBars s

469 |   displayEv (Move _ _)       s = selectCursor s

470 |   displayEv MiddleDown       s = selectCursor s

471 |   displayEv MiddleUp         s = selectCursor s

472 |   displayEv LeftUp           s = adjustBars s

473 |   displayEv Undo             s = adjustBars s

474 |   displayEv Redo             s = adjustBars s

475 |   displayEv (ZoomIn _)       s = adjustBars s

476 |   displayEv (ZoomOut _)      s = adjustBars s

477 |   displayEv Clear            s = adjustBars s

478 |   displayEv SVG              s = ex.doExport s

479 |   displayEv Redraw           s = displayST True s

480 |   displayEv _                s = pure ()

483 |   export

484 |   displaySketcher : DrawEvent -> DrawState -> Act ()

485 |   displaySketcher e s =

486 |     displayEv e s >> displayST False s >> ex.adjust (DE pre) e s

489 | disableExport : DrawEnv => DrawState -> Act ()

490 | disableExport @{DE pre} = disabled (expButton pre) . emptyGraph

497 | displayMol :

498 |      {auto ds : DrawSettings}

499 |   -> SceneDims

500 |   -> MolGraphAT

501 |   -> Maybe (List Nat)

502 |   -> HTMLNode

503 | displayMol sd g m =

504 |   let cdg    := initGraph g

505 |       G o mg := maybe cdg (\ns => highlight ns cdg) m

506 |    in Raw . curSVG $ initMol sd Fill False "" $ G o mg

508 | parameters {auto ex : Extension}

509 |            {auto lc : DrawLocal}

510 |            (getDS   : Act DrawSettings)

512 |   doact : Sink DrawEvent => String -> DrawState -> DrawEvent -> Act DrawState

513 |   doact pre s e = Prelude.do

514 |     logLoggable e

515 |     ds <- getDS

516 |     let s2 := update e s

517 |     displaySketcher pre e s2 $> s2

519 |   ||| An editor for molecules.

520 |   export

521 |   molWidget : String -> SceneDims -> Maybe MolfileAT -> Act (Widget DrawState)

522 |   molWidget pre sd m = Prelude.do

523 |     ds     <- getDS

524 |     E es   <- event DrawEvent

525 |     let st := fromMol sd Init (maybe (G 0 empty) graph m)

526 |     topadd <- ex.buttons (DE pre) st

527 |     let nd := sketcher pre topadd st

528 |     pure $ Widget.Types.W [nd] $

529 |       P.evalScans1 st (doact pre) es |> (\x => cons st x)

531 |   ||| An editor for molecules.

532 |   export

533 |   molEdit : SceneDims -> Editor MolfileAT

534 |   molEdit sd =

535 |     E $ \m => Prelude.do

536 |       ui <- map interpolate uniqueID

537 |       map (Valid . toMolfile . mol) <$> molWidget ui sd m

541 | NoExt : DrawLocal => Extension

542 | NoExt =

543 |   E

544 |     { doExport = storeSVG . exportSVG

545 |     , buttons  = \_,s => pure [expBtn saveTxt s]

546 |     , adjust   = \_,_,s => disableExport s

547 |     }