0 | module CyBy.Draw

  2 | import Data.Finite

  3 | import Data.List

  4 | import Geom

  5 | import Text.CSS

  6 | import Text.HTML.DomID

  7 | import Text.HTML.Select

  8 | import Text.Show.Pretty

  9 | import Text.SVG

 10 | import Web.Async

 11 | import Web.Internal.Types

 13 | import CyBy.Draw.Internal.Color

 14 | import CyBy.Draw.Internal.Label

 15 | import Geom.Gen2D.Debug

 17 | import public CyBy.Draw.Draw

 18 | import public CyBy.Draw.Event

 19 | import public CyBy.Draw.Internal.Abbreviations

 20 | import public CyBy.Draw.Internal.Atom

 21 | import public CyBy.Draw.Internal.CoreDims

 22 | import public CyBy.Draw.Internal.Graph

 23 | import public CyBy.Draw.Internal.Ring

 24 | import public CyBy.Draw.Internal.Role

 25 | import public CyBy.Draw.Internal.Settings

 26 | import public CyBy.Draw.MoleculeCanvas

 27 | import public CyBy.Draw.PeriodicTableCanvas

 28 | import public Text.Molfile

 30 | %default total

 33 | color : ColorScheme -> Elem -> SVGColor

 34 | color Black  = const black

 35 | color CyBy   = basicColors

 36 | color Groups = groupColors

 37 | color CPK    = cpkColor

 38 | color CDK    = cdkColor

 39 | color JMol   = jmolColor

 40 | color PyMol  = pymolColor

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

 44 | molToClipboard = toClipboard . writeMolfile . toMolfile

 46 | fromClipboard : Sink DrawEvent => Loggable JS DrawMsg => Act ()

 47 | fromClipboard =

 48 |   readFromClipboard >>= \s =>

 49 |     case readMolfileE s of

 50 |       Left x  => case smilesToMol s of

 51 |         Left  _ => logLoggable (ReadErr x)

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

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

 56 | storeSVG : String -> Act ()

 57 | storeSVG s =

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

 59 |     e  <- createElement "a"

 60 |     setAttribute e "href" (cast u)

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

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

 63 |     click he

 70 | public export

 71 | record DrawEnv where

 72 |   [noHints]

 73 |   constructor DE

 74 |   pre          : String

 75 |   {auto sets   : DrawSettings}

 76 |   {auto events : Sink DrawEvent}

 84 | public export

 85 | record Extension where

 86 |   [noHints]

 87 |   constructor E

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

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

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

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

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

102 | down : MouseInfo -> Maybe DrawEvent

103 | down mi = case mi.button of

104 |   0 => Just LeftDown

105 |   1 => Just MiddleDown

106 |   _ => Nothing

108 | up : MouseInfo -> Maybe DrawEvent

109 | up mi = case mi.button of

110 |   0 => Just LeftUp

111 |   1 => Just MiddleUp

112 |   _ => Nothing

114 | move : MouseInfo -> Maybe DrawEvent

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

117 | wheel : WheelInfo -> Maybe DrawEvent

118 | wheel wi =

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

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

121 |      else Nothing

128 | moleculeCanvas : String -> Ref Div

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

132 | sketcherDiv : String -> Ref Div

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

136 | sketcherDivInner : String -> Ref Div

137 | sketcherDivInner pre = Id "\{pre}-sketcher-div-inner"

140 | molReader : String -> Ref Div

141 | molReader pre = Id "\{pre}-mol-reader"

144 | molInput : String -> Ref TextArea

145 | molInput pre = Id "\{pre}-mol-input"

148 | leftBarID : String -> Ref Div

149 | leftBarID pre = Id "\{pre}-left-bar"

152 | rightBarID : String -> Ref Div

153 | rightBarID pre = Id "\{pre}-right-bar"

156 | topBarID : String -> Ref Div

157 | topBarID pre = Id "\{pre}-top-bar"

160 | bottomBarID : String -> Ref Div

161 | bottomBarID pre = Id "\{pre}-bottom-bar"

164 | abbrID : String -> Ref Tag.Select

165 | abbrID pre = Id "\{pre}-abbreviations"

168 | expButton : String -> Ref Tag.Button

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

174 |   

175 | hidden : {0 t : _} -> Attribute t

176 | hidden = class "hidden"

178 | abbrCls : DrawState -> List Class

179 | abbrCls s =

180 |   case s.mode of

181 |     SetAbbr _ => ["cyby-draw-select","active"]

182 |     _         => ["cyby-draw-select"]

184 | drawing : MolBond -> DrawState -> Bool

185 | drawing b s =

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

187 |   (s.bond == b)

189 | setting : Elem -> DrawState -> Bool

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

192 | %inline fromStereo : BondStereo -> MolBond

193 | fromStereo = MkBond True Single

195 | disable : Bool -> HTMLNode -> HTMLNode

196 | disable b = withAttribute (disabled b)

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

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

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

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

204 | pse : Mode -> Bool

205 | pse (PTable _)  = True

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

207 | pse _           = False

209 | detail : String -> HTMLNode -> HTMLNode

210 | detail title n =

211 |   div

212 |     [class "cyby-draw-detail"]

213 |     [label [ class "cyby-draw-label" ] [ Text title ], n]

215 | px : Double -> String

216 | px v = show (cast {to = Bits32} v) ++ "px"

218 | parameters {auto de : Sink DrawEvent}

220 |   elems : MolAtomAT -> HTMLNode

221 |   elems a =

222 |     selectFromListBy values (a.elem.elem ==) symbol ChgElem

223 |       [ class "cyby-draw-select", title "Set Element" ]

225 |   charges : MolAtomAT -> HTMLNode

226 |   charges a =

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

228 |       [ class "cyby-draw-select", title "Set Charge" ]

229 |     where

230 |       chs : List Charge

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

233 |   massNrs : MolAtomAT -> HTMLNode

234 |   massNrs a =

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

236 |       [ class "cyby-draw-select", title "Set Charge" ]

237 |     where

238 |       dispMass : Maybe MassNr -> String

239 |       dispMass Nothing  = "Mix"

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

241 |   

242 |   icon' :

243 |        List (Attribute Tag.Button)

244 |     -> (cls : Class)

245 |     -> DrawEvent

246 |     -> (title : String)

247 |     -> HTMLNode

248 |   icon' as cls ev ttl =

249 |     button (classes ["cyby-draw-icon", cls] :: onClick ev :: title ttl :: as) []

251 |   %inline

252 |   icon : (cls : Class) -> DrawEvent -> (title : String) -> HTMLNode

253 |   icon = icon' []

255 |   radioIcon : (cls : Class) -> DrawEvent -> (ttl : String) -> Bool -> HTMLNode

256 |   radioIcon cls ev ttl b =

257 |     input

258 |       [ name "tool"

259 |       , type Radio

260 |       , classes ["cyby-draw-radio-icon", cls]

261 |       , onClick ev, title ttl

262 |       , checked b

263 |       ]

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

266 |   abbrs pre s =

267 |     selectFromListBy

268 |       ds.abbreviations

269 |       (\a => any ((a.label ==) . label) s.abbr)

270 |       label

271 |       SelAbbr

272 |       [ Id $ abbrID pre

273 |       , classes $ abbrCls s

274 |       , title "Abbreviations"

275 |       , Event (MouseDown $ \mi => toMaybe (mi.button == 0) EnableAbbr)

276 |       ]

278 |   bondIcon : Class -> MolBond -> String -> DrawState -> HTMLNode

279 |   bondIcon c b title = radioIcon c (SetBond b) title . drawing b

281 |   topBar :

282 |        {auto ds : DrawSettings}

283 |     -> (pre     : String)

284 |     -> (topadd  : HTMLNodes)

285 |     -> DrawState

286 |     -> HTMLNode

287 |   topBar {ds} pre topadd s =

288 |     div

289 |       [ Id $ topBarID pre, class "cyby-draw-toolbar-top" ] $

290 |       [ radioIcon "sel" SelectMode "select" (s.mode == Select)

291 |       , radioIcon "erase" EraseMode "erase" (s.mode == Erase)

292 |       , disable (emptyGraph s) $ icon "clear" Clear "clear"

293 |       , disable (s.undos == []) $ icon "undo" Undo "undo"

294 |       , disable (s.redos == []) $ icon "redo" Redo "redo"

295 |       , icon "center" Center "center"

296 |       , disable (maxZoom s.transform) $ icon "zoom-in" (ZoomIn False) "zoom in"

297 |       , disable (minZoom s.transform) $ icon "zoom-out" (ZoomOut False) "zoom out"

298 |       , bondIcon "single-bond" (cast Single) "single bond" s

299 |       , bondIcon "single-up" (fromStereo Up) "single bond up" s

300 |       , bondIcon "single-down" (fromStereo Down) "single bond down" s

301 |       , bondIcon "single-up-down" (fromStereo Either) "single bond up or down" s

302 |       , bondIcon "double-bond" (cast Chem.Types.Dbl) "double bond" s

303 |       , bondIcon "triple-bond" (cast Triple) "triple bond" s

304 |       ] ++ topadd

306 |   template : (cls : Class) -> CDGraph -> String -> DrawState -> HTMLNode

307 |   template cls g nm s =

308 |     radioIcon cls (SetTempl g) "Template \{nm}" (s.mode == SetTempl g)

310 |   leftBar : (pre : String) -> DrawState -> HTMLNode

311 |   leftBar pre s =

312 |     div

313 |       [ Id $ leftBarID pre, class "cyby-draw-toolbar-left" ]

314 |       [ radioIcon "set-c" (SetElem C) "Carbon" (setting C s)

315 |       , radioIcon "set-o" (SetElem O) "Oxygen" (setting O s)

316 |       , radioIcon "set-n" (SetElem N) "Nitrogen" (setting N s)

317 |       , radioIcon "set-f" (SetElem F) "Fluorine" (setting F s)

318 |       , radioIcon "set-p" (SetElem P) "Phosphorus" (setting P s)

319 |       , radioIcon "set-s" (SetElem S) "Sulfur" (setting S s)

320 |       , radioIcon "set-cl" (SetElem Cl) "Chlorine" (setting Cl s)

321 |       , radioIcon "set-br" (SetElem Br) "Bromine" (setting Br s)

322 |       , radioIcon "pse" StartPSE "PSE" (pse s.mode)

323 |       ]

326 |   rightBar : (pre : String) -> DrawState -> HTMLNode

327 |   rightBar pre s =

328 |     case selectedNodes s.imol False of

329 |       [n] =>

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

331 |             tpe     := atm.type.name

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

333 |             cx      := dispCoordShort x

334 |             cy      := dispCoordShort y

335 |          in div

336 |               [ Id $ rightBarID pre, class "cyby-draw-toolbar-right" ]

337 |               [ detail "Element"  $ elems atm

338 |               , detail "Isotope"  $ massNrs atm

339 |               , detail "Charge"   $ charges atm

340 |               , detail "Type"     $ div [ class "cyby-draw-atomtype"] [Text tpe]

341 |               , detail "x-Coord." $ div [ class "cyby-draw-atomtype"] [Text cx]

342 |               , detail "y-Coord." $ div [ class "cyby-draw-atomtype"] [Text cy]

343 |               ]

344 |       _   => case selectedEdges s.imol of

345 |         [(x,y)] =>

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

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

348 |               d  := printDouble 3 $ distance px py

349 |               a  := angleOrZero (px - py)

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

351 |            in div

352 |                 [ Id $ rightBarID pre, class "cyby-draw-toolbar-right" ]

353 |                 [ detail "Length"   $ div [ class "cyby-draw-atomtype"] [Text "\{d} Å"]

354 |                 , detail "Angle"    $ div [ class "cyby-draw-atomtype"] [Text "\{a'}°"]

355 |                 ]

356 |         _       => div [ Id $ rightBarID pre, class "cyby-draw-toolbar-right" ] []

358 |   bottomBar : (pre : String) -> DrawState -> HTMLNode

359 |   bottomBar pre s =

360 |     div

361 |       [ Id $ bottomBarID pre, class "cyby-draw-toolbar-bottom-inner" ]

362 |       [ template "benzene" phenyl "Benzene" s

363 |       , template "cyclohexane" (ring 6) "Cyclohexane" s

364 |       , template "cyclopentane" (ring 5) "Cyclopentane" s

365 |       , template "cyclopropane" (ring 3) "Cyclopropane" s

366 |       , template "cyclobutane" (ring 4) "Cyclobutane" s

367 |       , template "cycloheptane" (ring 7) "Cycloheptane" s

368 |       , template "cyclooctane" (ring 8) "Cyclooctane" s

369 |       ]

371 |   export

372 |   sketcher :

373 |        {auto ds : DrawSettings}

374 |     -> (pre     : String)

375 |     -> (topadd  : HTMLNodes)

376 |     -> DrawState

377 |     -> HTMLNode

378 |   sketcher pre topadd s =

379 |     div

380 |       [ class "cyby-draw-main-content"

381 |       , Id $ sketcherDiv pre

382 |       ]

383 |       [ div

384 |         [ class "cyby-draw-sketcher-div"

385 |         , Id $ sketcherDivInner pre

386 |         ]

387 |         [ topBar pre topadd s

388 |         , leftBar pre s

389 |         , rightBar pre s

390 |         , div

391 |             [ class "cyby-draw-molecule-canvas"

392 |             , Id $ moleculeCanvas pre

393 |             , Event $ MouseMove move

394 |             , Event $ MouseDown down

395 |             , Event $ MouseUp up

396 |             , Event_ True False $ Wheel wheel

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

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

399 |             , onMouseEnter Draw.Event.Focus

400 |             , onMouseLeave Draw.Event.Blur

401 |             , onDblClick Expand

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

403 |             , Str "tabindex" "1"

404 |             , style

405 |                 [ width $ px $ cast s.dims.swidth

406 |                 , height $ px $ cast s.dims.sheight

407 |                 ]

408 |             ]

409 |             [Raw s.curSVG]

410 |         , div

411 |             [ class "cyby-draw-toolbar-bottom-outer" ]

412 |             [ bottomBar pre s, abbrs pre s ]

413 |         ]

414 |       ]

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

418 | cybyDrawBtn s e as =

419 |   button (class "cyby-draw-button" :: onClick e :: as) [Text s]

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

423 | expBtn @{DE pre} txt s =

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

430 | molCanvasCls : Class

431 | molCanvasCls = "cyby-draw-molecule-canvas"

433 | parameters {auto ds : DrawSettings}

434 |            {auto se : Sink DrawEvent}

435 |            {auto lm : Loggable JS DrawMsg}

436 |            {auto ex : Extension}

437 |            (pre : String)

439 |   canvasCls : List Class -> Act ()

440 |   canvasCls = attr (moleculeCanvas pre) . classes . (molCanvasCls ::)

442 |   rotating : Act ()

443 |   rotating = canvasCls ["rotating"]

445 |   dragging : Act ()

446 |   dragging = canvasCls ["dragging"]

448 |   normal : Act ()

449 |   normal = canvasCls []

451 |   selectCursor : DrawState -> Act ()

452 |   selectCursor s =

453 |     case s.mode of

454 |       Dragging _    => dragging

455 |       Rotating _    => rotating

456 |       RotTempl _ _  => rotating

457 |       Translating _ => dragging

458 |       _             => applyWhenSel s dragging rotating normal

460 |   adjAbbrCls : DrawState -> Act ()

461 |   adjAbbrCls s = attr (abbrID pre) . classes $ abbrCls s

463 |   focusCurrentApp : Act ()

464 |   focusCurrentApp = focus (moleculeCanvas pre)

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

467 |   displayST force s =

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

469 |       child (moleculeCanvas pre) (Raw s.curSVG) >>

470 |       when s.hasFocus focusCurrentApp

472 |   adjustBars : DrawState -> Act ()

473 |   adjustBars s = Prelude.do

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

475 |     replace (topBarID pre) (topBar pre topadd s)

476 |     replace (bottomBarID pre) (bottomBar pre s)

477 |     replace (leftBarID pre) (leftBar pre s)

478 |     adjAbbrCls s

480 |   adjustRightBar : DrawState -> Act ()

481 |   adjustRightBar s = do

482 |     replace (rightBarID pre) (rightBar pre s)

483 |     adjAbbrCls s

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

486 |   dispKeyDown "Escape" s = Prelude.do

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

488 |     replace (sketcherDiv pre) (sketcher pre topadd s)

489 |   dispKeyDown "c" s =

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

491 |       let g := selectedSubgraph True s.mol

492 |        in when (g.order > 0) (molToClipboard g >> logLoggable Copied)

493 |   dispKeyDown "x" s =

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

495 |       let g := selectedSubgraph False s.mol

496 |        in when (g.order > 0) (molToClipboard g >> logLoggable Copied)

497 |   dispKeyDown "v"    s =

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

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

500 |     -- processing

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

502 |   dispKeyDown "Ctrl" s = selectCursor s

503 |   dispKeyDown _      s = pure ()

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

506 |   displayEv Focus            s = focusCurrentApp

507 |   displayEv Blur             s = blur (moleculeCanvas pre)

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

509 |   displayEv (KeyUp _)        s = adjustRightBar s

510 |   displayEv (SetElem _)      s = adjustBars s

511 |   displayEv (SelAbbr _)      s = adjustBars s

512 |   displayEv  EnableAbbr      s = adjustBars s

513 |   displayEv (SetBond _)      s = adjustBars s

514 |   displayEv (SetTempl _)     s = adjustBars s

515 |   displayEv (Load _)         s = adjustBars s

516 |   displayEv SelectMode       s = adjustBars s

517 |   displayEv EraseMode        s = adjustBars s

518 |   displayEv (ChgElem _)      s = adjustRightBar s

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

520 |   displayEv MiddleDown       s = selectCursor s

521 |   displayEv MiddleUp         s = selectCursor s

522 |   displayEv LeftUp           s = adjustBars s >> adjustRightBar s

523 |   displayEv Undo             s = adjustBars s

524 |   displayEv Redo             s = adjustBars s

525 |   displayEv (ZoomIn _)       s = adjustBars s

526 |   displayEv (ZoomOut _)      s = adjustBars s

527 |   displayEv Clear            s = adjustBars s

528 |   displayEv SVG              s = ex.doExport s

529 |   displayEv Redraw           s = displayST True s

530 |   displayEv _                s = pure ()

533 |   export

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

535 |   displaySketcher e s =

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

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

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

547 | displayMol :

548 |      {auto ds : DrawSettings}

549 |   -> SceneDims

550 |   -> MolGraphAT

551 |   -> Maybe (List Nat)

552 |   -> HTMLNode

553 | displayMol sd g m =

554 |   let cdg    := initGraph g

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

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

560 | molEdit :

561 |      {auto ex : Extension}

562 |   -> {auto lg : Loggable JS DrawMsg}

563 |   -> Act DrawSettings

564 |   -> SceneDims

565 |   -> Editor MolfileAT

566 | molEdit getDS sd =

567 |   E $ \m => Prelude.do

568 |    ui     <- map interpolate uniqueID

569 |    ds     <- getDS

570 |    E es   <- event DrawEvent

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

572 |    topadd <- ex.buttons (DE ui) st

573 |    let nd := sketcher ui topadd st

574 |    pure $ Widget.W nd $

575 |      es |> P.evalScans1 st (doact ui)

576 |         |> (\x => cons st x)

577 |         |> P.mapOutput (Valid . toMolfile . mol)

579 |    where

580 |      doact :

581 |           {auto ds : DrawSettings}

582 |        -> {auto se : Sink DrawEvent}

583 |        -> (pre     : String)

584 |        -> DrawState

585 |        -> DrawEvent

586 |        -> Act DrawState

587 |      doact pre s e = let s2 := update e s in displaySketcher pre e s2 $> s2

590 | export %hint

591 | NoExt : Extension

592 | NoExt =

593 |   E

594 |     { doExport = storeSVG . exportSVG

595 |     , buttons  = \_,s => pure [expBtn "Save..." s]

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

597 |     }