0 | module CyBy.Draw.MoleculeCanvas

  2 | import Chem.Util

  3 | import CyBy.Draw.Draw

  4 | import CyBy.Draw.Event

  5 | import CyBy.Draw.Internal.Abbreviations

  6 | import CyBy.Draw.Internal.Atom

  7 | import CyBy.Draw.Internal.CoreDims

  8 | import CyBy.Draw.Internal.Graph

  9 | import CyBy.Draw.Internal.Label

 10 | import CyBy.Draw.Internal.Ring

 11 | import CyBy.Draw.Internal.Role

 12 | import CyBy.Draw.Internal.Settings

 13 | import CyBy.Draw.PeriodicTableCanvas

 14 | import Derive.Prelude

 15 | import Geom

 16 | import Text.Molfile

 17 | import Text.SVG

 18 | import CyBy.Draw.Internal.Navigation

 20 | %default total

 21 | %language ElabReflection

 22 | %hide Language.Reflection.TTImp.Mode

 25 | public export

 26 | record DepNode where

 27 |   constructor DN

 28 |   graph : CDGraph

 29 |   node  : Fin graph.order

 31 | %runElab derive "DepNode" [Show]

 34 | Eq DepNode where

 35 |   (==) (DN g1 n1) (DN g2 n2) = g1 == g2 && finToNat n1 == finToNat n2

 41 | public export

 42 | data Mode : Type where

 43 |   Select      : Mode

 44 |   Erase       : Mode

 45 |   Draw        : Mode

 46 |   SetAtom     : Isotope -> Mode

 47 |   SetAbbr     : Abbreviation -> Mode

 48 |   SetTempl    : CDGraph -> Mode

 49 |   RotTempl    : (start : Point Mol) -> (t : CDGraph) -> Mode

 50 |   RotTemplAtm : DepNode -> CDGraph -> Mode

 51 |   RotTemplOvp : (g,t : DepNode) -> (initPoint : Point Mol) -> Mode

 52 |   Selecting   : (start : Point Id) -> Mode

 53 |   Erasing     : (start : Point Id) -> Mode

 54 |   Dragging    : (start : Point Mol) -> Mode

 55 |   Rotating    : (start : Point Mol) -> Mode

 56 |   Translating : (prev : Mode) -> Mode

 57 |   Drawing     : Maybe Abbreviation -> Mode

 58 |   PTable      : (hovered : Maybe Elem) -> Mode

 60 | %runElab derive "CyBy.Draw.MoleculeCanvas.Mode" [Show,Eq]

 62 | endTranslate : Mode -> Mode

 63 | endTranslate (Translating m) = m

 64 | endTranslate m               = m

 70 | sameAtom : Isotope -> CDAtom -> Bool

 71 | sameAtom i a = elem a.atom == i && not (inAnyGroup a) && a.atom.charge == 0

 73 | hoverAtom : Mode -> CDAtom -> Bool

 74 | hoverAtom Select       _ = True

 75 | hoverAtom Erase        _ = True

 76 | hoverAtom Draw         y = not (inAnyGroup y)

 77 | hoverAtom (SetAtom x)  y = not (sameAtom x y)

 78 | hoverAtom (SetAbbr x)  y = map lbl (group y) /= Just x.label

 79 | hoverAtom (SetTempl x) y = not (inAnyGroup y)

 80 | hoverAtom _            _ = False

 82 | hoverDrawing : MolBond -> MolBond -> Bool -> Bool

 83 | hoverDrawing (MkBond _ Single NoBondStereo) _ a = not a

 84 | hoverDrawing (MkBond _ Single Either)       b _ = b.stereo /= Either

 85 | hoverDrawing (MkBond _ Single _)            _ _ = True

 86 | hoverDrawing (MkBond _ x      _)            b a = not a && b.type /= x

 88 | hoverBond : Mode -> MolBond -> CDBond -> (inAbbreviation : Bool) -> Bool

 89 | hoverBond Select       _  _ _ = True

 90 | hoverBond Erase        _  _ _ = True

 91 | hoverBond Draw         mb b a = hoverDrawing mb b.molBond a

 92 | hoverBond (SetTempl x) _  _ b = not b

 93 | hoverBond _            _  _ _ = False

 99 | public export

100 | record DrawState where

101 |   [noHints]

102 |   constructor ST

103 |   dims       : SceneDims

104 |   transform  : AffineTransformation

105 |   curPos     : Point transform

106 |   mol        : CDGraph

107 |   undos      : List (CDGraph)

108 |   redos      : List (CDGraph)

109 |   mode       : Mode

110 |   modifier   : Modifier

111 |   bond       : MolBond

112 |   abbr       : Maybe Abbreviation

113 |   hasFocus   : Bool

114 |   ptable     : Maybe Elem

116 |   ||| Current SVG scene rendered to a string

119 |   curSVG     : String

121 |   ||| Previous SVG scene rendered to a string

122 |   prevSVG    : String

124 | export %inline

125 | toMol : DrawState -> MolfileAT

126 | toMol ds = toMolfile ds.mol

128 | export %inline

129 | toMolStr : DrawState -> (comment : String) -> String

130 | toMolStr s c =

131 |   case toMol s of

132 |     (MkMolfile n i _ g d) =>

133 |       let molFile := MkMolfile n i (MkMolLine c) g d

134 |        in writeMolfile molFile

136 | export %inline

137 | (.imol) : (s : DrawState) -> CDIGraph s.mol.order

138 | s.imol = s.mol.graph

141 | export %inline

142 | emptyGraph : DrawState -> Bool

143 | emptyGraph s = order s.mol == 0

154 | public export

155 | data ScaleMode : Type where

156 |   ||| Scale mode used when initializing a scene for drawing

157 |   Init  : ScaleMode

159 |   ||| Scale mode used when centering the molecule (by pressing the "reset" button)

160 |   Reset : ScaleMode

162 |   ||| Scale mode used when displaying a molecule so that it fills the whole

164 |   Fill  : ScaleMode

166 | setTransform : AffineTransformation -> DrawState -> DrawState

167 | setTransform tr = {transform := tr, curPos $= convert}

169 | scaleTrans :

170 |      {auto ds : DrawSettings}

171 |   -> Point Id

172 |   -> Scale

173 |   -> AffineTransformation

174 |   -> AffineTransformation

175 | scaleTrans p sc t =

176 |   let v := p - origin

177 |    in translate v <+> scaling (validScale t sc) <+> translate (negate v) <+> t

179 | parameters {auto ds : DrawSettings}

181 |   export

182 |   scaleAt : Point Id -> Scale -> DrawState -> DrawState

183 |   scaleAt p sc s = setTransform (scaleTrans p sc s.transform) s

185 |   ||| Scales the molecule at the current mouse position.

186 |   export

187 |   scaleAtPos : Scale -> DrawState -> DrawState

188 |   scaleAtPos sc s = let P x y := s.curPos in scaleAt (P x y) sc s

190 |   ||| Scales the molecule at the center of the scene

191 |   export

192 |   scaleAtCenter : Scale -> DrawState -> DrawState

193 |   scaleAtCenter sc s = scaleAt (sceneCenter s.dims) sc s

195 |   scaleFromBounds : (scene,mol : Bounds2D Id) -> Scale

196 |   scaleFromBounds c m     =

197 |     min (factor (width c) (width m)) (factor (height c) (height m))

198 |     where

199 |       factor : Double -> Double -> Scale

200 |       factor x y = scale $ (x / (y + 4.0 * cast ds.core.fontSize))

202 |   iniTrans : SceneDims -> ScaleMode -> CDGraph -> AffineTransformation

203 |   iniTrans sd sm (G _ g) =

204 |     let (bs,sc) := scaleToBounds

205 |      in scaleTrans (sceneCenter sd) sc $

206 |           translate (sceneCenter sd - convert (center bs))

207 |     where

208 |       scaleToBounds : (Bounds2D Id, Scale)

209 |       scaleToBounds =

210 |         case sm of

211 |           Init  =>

212 |             let bs := foldMap bounds (Draw.labels g)

213 |              in (bs,1.0)

214 |           Reset =>

215 |            let bs := foldMap bounds (Draw.labels g)

216 |             in (bs, min 1.0 (scaleFromBounds (sceneBounds sd) bs))

217 |           Fill =>

218 |            let bs = foldMap bounds (Draw.labels g)

219 |             in (bs, scaleFromBounds (sceneBounds sd) bs)

221 |   initAbbr : Maybe Abbreviation

222 |   initAbbr = case ds.abbreviations of {a :: _ => Just a; [] => Nothing}

225 | (.posId) : DrawState -> Point Id

226 | s.posId = convert s.curPos

229 | (.posMol) : DrawState -> Point Mol

230 | s.posMol = convert s.curPos

242 | nextMol : DrawSettings => DrawState -> CDGraph

243 | nextMol s =

244 |   case s.hasFocus of

245 |     False => s.mol

246 |     True  => case s.mode of

247 |       Select           => s.mol

248 |       Erase            => s.mol

249 |       Draw             => s.mol

250 |       PTable _         => s.mol

251 |       SetAtom x        => addAtom s.imol x s.curPos

252 |       SetAbbr _        => s.mol

253 |       Erasing p        => select p s.posId s.mol

254 |       Translating _    => s.mol

255 |       Selecting p      => select p s.posId s.mol

256 |       Dragging p       => moveSelected p s.posMol s.mol

257 |       Rotating p       => rotateSelected (s.modifier == Shift) p s.posMol s.mol

258 |       SetTempl t       => addTemplate s.posMol t s.mol

259 |       RotTempl p t     => addTemplate p (rotateTempl False p s.posMol t) s.mol

260 |       RotTemplOvp g t p =>

261 |         addTemplateRot s.posMol (Right (g.node,t.node,p)) t.graph.graph g.graph.graph

262 |       RotTemplAtm g t => addTemplateRot s.posMol (Left g.node) t.graph g.graph.graph

263 |       Drawing Nothing  => addBond (s.modifier == Shift) (Just s.posMol) s.bond s.imol

264 |       Drawing (Just $ A l _ g) => setAbbreviation (s.modifier == Shift) l s.posId g s.mol

271 | updateMol : (CDGraph -> CDGraph) -> DrawState -> DrawState

272 | updateMol f s =

273 |   let G o g := cleanup $ f s.mol

274 |       cm    := clear s.mol

275 |    in if clear (G o g) == cm then s else

276 |         { mol := G o $ adjAtomTypes g

277 |         , undos $= (cm ::), redos := []

278 |         } s

282 | modAtomWhere :

283 |      (CDAtom -> Bool)

284 |   -> (MolAtomAT -> MolAtomAT)

285 |   -> DrawState

286 |   -> DrawState

287 | modAtomWhere p f =

288 |   updateMol $ \(G o g) =>

289 |     let ns := filter (p . lab g) (nodes g)

290 |      in delNodes (groupNodes g ns) $ mapIf p {atom $= adj} g

291 |   where

292 |     adj : MolAtomAT -> MolAtomAT

293 |     adj = f . {label := Nothing}

297 | modAtom : (MolAtomAT -> MolAtomAT) -> DrawState -> DrawState

298 | modAtom = modAtomWhere (is Hover)

301 | setMol : CDGraph -> DrawState -> DrawState

302 | setMol = updateMol . const

306 | delete : DrawState -> DrawState

307 | delete = updateMol (clear . deleteSelected)

315 | drawSelection : (se : DrawSettings) => DrawState -> List SVGNode

316 | drawSelection s = case s.mode of

317 |   Erasing p    => [fillRect se.selectFG p s.posId]

318 |   RotTempl p _ => rotateTemplScene p s.posMol

319 |   Selecting p  => [fillRect se.selectFG p s.posId]

320 |   _           =>

321 |     -- tests if any atoms are selected and if that's the case, whether

322 |     -- the mouse is currently in the dragging zone.

323 |     case selectionCorners (nextMol s) of

324 |       Nothing      => []

325 |       Just (p1,p2) =>

326 |         let SZ d1 d2 r1 r2 := selectZones (convert p1) (convert p2)

327 |          in if inRectangle s.posId d1 d2

328 |                then [outlineRect se.hoverBG d1 d2]

329 |                else [outlineRectD se.hoverBG r1 r2]

335 | resizeCorner : (s : DrawState) -> Point s.transform

336 | resizeCorner s = let SD h w := s.dims in P h w

338 | maybeResizing : DrawSettings => DrawState -> Bool

339 | maybeResizing @{x} s =

340 |   distance s.curPos (resizeCorner s) <= x.resizeCornerRad

342 | reset : DrawSettings => DrawState -> DrawState

343 | reset s = {transform := iniTrans s.dims Reset s.mol, curPos := origin} s

345 | initST : DrawSettings => SceneDims -> ScaleMode -> CDGraph -> DrawState

346 | initST sd sm g =

347 |   ST

348 |     { dims       = sd

349 |     , curPos     = P (sd.swidth / 2.0) (sd.sheight / 2.0)

350 |     , transform  = iniTrans sd sm g

351 |     , mol        = g

352 |     , undos      = []

353 |     , redos      = []

354 |     , mode       = Draw

355 |     , modifier   = NoMod

356 |     , bond       = MkBond False Single NoBondStereo

357 |     , abbr       = initAbbr

358 |     , hasFocus   = False

359 |     , ptable     = Nothing

360 |     , curSVG     = ""

361 |     , prevSVG    = ""

362 |     }

364 | undo : DrawState -> DrawState

365 | undo s = case s.undos of

366 |   []     => s

367 |   (h::t) => {redos $= (clear s.mol ::), mol := h, undos := t} s

369 | redo : DrawState -> DrawState

370 | redo s = case s.redos of

371 |   []     => s

372 |   (h::t) => {undos $= (clear s.mol ::), mol := h, redos := t} s

374 | changeSelMode : DrawState -> DrawState

375 | changeSelMode s =

376 |   let mode := if s.modifier == Shift then Many else One

377 |    in case hoveredItem s.imol of

378 |         None => {mode := Selecting s.posId, mol $= selectHovered Ignore Ignore} s

379 |         N _  => {mode := Dragging s.posMol, mol $= selectHovered Ignore mode} s

380 |         E _  => {mode := Dragging s.posMol, mol $= selectHovered mode Ignore} s

382 | parameters {auto ds : DrawSettings}

383 |   -- Elaborates the current mode and elevates the fitting argument to a return

384 |   -- value

385 |   export

386 |   applyWhenSel :

387 |        {0 a : Type}

388 |     -> DrawState

389 |     -> (dragging : Lazy a)

390 |     -> (rotating : Lazy a)

391 |     -> (nothing : Lazy a)

392 |     -> a

393 |   applyWhenSel s d r n =

394 |     let pid := s.posId

395 |     in case hoveredItem s.imol of

396 |          None => case selectionCorners s.mol of

397 |            Nothing      => n

398 |            Just (p1,p2) =>

399 |              let SZ d1 d2 r1 r2 := selectZones (convert p1) (convert p2)

400 |               in case inRectangle pid d1 d2 of

401 |                    False => case inRectangle pid r1 r2 of

402 |                      False => n

403 |                      True  => r

404 |                    True  => d

405 |          _ => n

407 |   -- When we move the mouse, we must adjust the current mouse position

408 |   -- in the application state. If the middle mouse button is pressed,

409 |   -- we also translate the drawing area, otherwise we adjust the hovering

410 |   -- state of atoms.

411 |   move : (s : DrawState) -> Point s.transform -> DrawState

412 |   move s p =

413 |     case s.mode of

414 |       Translating _ =>

415 |         let V x y := p - s.curPos

416 |             v     := vid x y

417 |          in setTransform (translate v <+> s.transform) s

418 |       PTable m      => {mode := PTable (hoveredElem s.dims p)} s

419 |       m             =>

420 |         let G o g := s.mol

421 |             gh    := hover (hoverBond m s.bond) (hoverAtom m) (convert p) g

422 |          in { mol := G o gh, curPos := p} s

424 |   -- Pressing the left button typically begins an editing step

425 |   -- If this step depends on the start and end position of the mouse,

426 |   -- we enter a new mode and finish editing on the `leftUp` event.

427 |   -- Otherwise (for instance, when setting the label of an atom at

428 |   -- the mouse position),

429 |   -- the modification happens immediately.

430 |   leftDown : DrawState -> DrawState

431 |   leftDown s =

432 |     if maybeResizing s then s else

433 |       let pid := s.posId

434 |        in case s.mode of

435 |             Select      =>

436 |               applyWhenSel

437 |                 s

438 |                 (updateMode s (Dragging s.posMol))

439 |                 (updateMode s (Rotating s.posMol))

440 |                 (changeSelMode s)

442 |             Erase       =>

443 |               case hoveredItem s.imol of

444 |                 None => {mode := Erasing s.posId} s

445 |                 N _  => delete $ {mol $= selectHovered Ignore One} s

446 |                 E _  => delete $ {mol $= selectHovered One Ignore} s

448 |             Draw        =>

449 |               case hoveredItem s.imol of

450 |                 None => setMol (G _ $ insElemAt s.imol C pid HoverNew) s 

451 |                 N x  =>

452 |                   if isJust (groupNr s.imol (fst x))

453 |                      then s

454 |                      else {mode := Drawing Nothing, mol $= ifHover Origin} s

455 |                 E (E x y $ CB r b)  => 

456 |                   let b2 := newBond s.bond.type s.bond.stereo b

457 |                    in setMol (G _ $ insEdge (E x y $ CB r b2) s.imol) s

459 |             SetAtom   i => setMol (nextMol s) s

460 |             SetAbbr a   => {mode := Drawing (Just a), mol $= ifHover Origin} s

461 |             SetTempl  t =>

462 |                 case hoveredItem s.imol of

463 |                   -- adding template at hovered atom

464 |                   N (f,_)  => {mode := RotTemplAtm (DN s.mol f) t} s

465 |                   _        =>

466 |                    let t' := graph $ translateTemplate s.posMol t

467 |                     in case nodesToMerge s.imol t' of

468 |                          -- exactly one overlap -> rotating around it possible

469 |                          [(fm, ft)] =>

470 |                            {mode := RotTemplOvp

471 |                                       (DN (G _ s.imol) fm)

472 |                                       (DN (G _ t') ft)

473 |                                       (convert s.curPos)} s

474 |                          _          =>

475 |                            setMol (nextMol s) $ {mode := SetTempl t} s

476 |             _ => s

477 |     where updateMode : DrawState -> Mode -> DrawState

478 |           updateMode s m = {mode := m} s

480 |   -- When the left mouse button is lifted, this ends an ongoing editing

481 |   -- or selection process. We typically overwrite the current molecule with

482 |   -- the freshly edited one, adjust the drawing roles of atoms and bonds, and

483 |   -- determine the currently hovered atom anew.

484 |   leftUp : DrawState -> DrawState

485 |   leftUp s =

486 |     case s.mode of

487 |       Selecting _ => {mode := Select, mol := cleanup (nextMol s)} s

488 |       Erasing   _ => delete $ {mode := Erase, mol := cleanup (nextMol s)} s

489 |       Dragging  _ => setMol (nextMol s) $ {mode := Select} s

490 |       Rotating  _ => setMol (nextMol s) $ {mode := Select} s

491 |       RotTemplAtm _ t => setMol (nextMol s) $ {mode := SetTempl t} s

492 |       RotTemplOvp _ t _ => setMol (nextMol s) $ {mode := SetTempl t.graph} s

493 |       Drawing (Just a) => setMol (nextMol s) $ {mode := SetAbbr a} s

494 |       Drawing Nothing  => setMol (nextMol s) $ {mode := Draw} s

495 |       PTable (Just el) => {mode := SetAtom (cast el)} s

496 |       PTable Nothing   => s

497 |       _           => {mol $= cleanup} s

499 |   %inline

500 |   zoomOut, zoomIn : (atPos : Bool) -> DrawState -> DrawState

501 |   zoomOut True  = scaleAtPos 0.8

502 |   zoomOut False = scaleAtCenter 0.8

504 |   zoomIn True  = scaleAtPos 1.25

505 |   zoomIn False = scaleAtCenter 1.25

507 | ifCtrl : (f,g : Lazy (DrawState -> DrawState)) -> DrawState -> DrawState

508 | ifCtrl f g s = if s.modifier == Ctrl then f s else g s

510 | setElemStr : String -> DrawState -> DrawState

511 | setElemStr s = modAtom {elem $= updateIsotope s, charge := 0}

513 | startTemplRot : DrawState -> Mode -> Mode

514 | startTemplRot s (SetTempl g) = RotTempl s.posMol g

515 | startTemplRot s m           = m

517 | stopTemplRot : DrawSettings => DrawState -> Mode -> Mode

518 | stopTemplRot s (RotTempl p g) = SetTempl (rotateTempl False p s.posMol g)

519 | stopTemplRot s m              = m

525 | addBondShortcut :

526 |      {auto cd : CoreDims}

527 |   -> Bool

528 |   -> BondOrder

529 |   -> BondStereo

530 |   -> DrawState

531 |   -> DrawState

532 | addBondShortcut bol bo bs s =

533 |   case hoveredItem s.imol of

534 |     N x => case inAbbreviation s.imol (fst x) of

535 |       True  => s

536 |       False =>

537 |        let bnd   := MkBond bol bo bs

538 |            G _ g := ifHover Origin s.mol

539 |         in setMol (hoverIfNew (addBond {t = Id} False Nothing bnd g)) s

540 |     E (E x y $ CB r b) =>

541 |       if bs == NoBondStereo then

542 |           setMol (G _ $ insEdge (E x y $ CB r (cast bo)) s.imol) s

543 |       else s

544 |     _ => s  -- If not hovering over a valid atom or Edge, do nothing

548 | addGroupShortcut :

549 |         {auto cd : CoreDims}

550 |      -> CDGraph -- For example 'phenyl', '(readMolfile ac)' or '(ring 5)'

551 |      -> DrawState

552 |      -> Bool -- To determine if anything should happen on an edge

553 |      -> DrawState

554 | addGroupShortcut g s bol =

555 |   case hoveredItem s.imol of

556 |     N x => case inAbbreviation s.imol (fst x) of 

557 |       True  => s 

558 |       False =>  

559 |            setMol (mergeGraphs s.posId s.mol g) s

560 |     E e => if bol then 

561 |                   setMol (mergeGraphs s.posId s.mol g) s

562 |             else s

563 |     _ => s 

567 | addAbbrShortcut :

568 |      {auto cd : CoreDims}

569 |   -> String

570 |   -> CDGraph

571 |   -> DrawState

572 |   -> DrawState

573 | addAbbrShortcut l g s =

574 |   case hoveredItem s.imol of

575 |     N x => case inAbbreviation s.imol (fst x) of

576 |       True  => s

577 |       False =>

578 |         let s := {mol $= ifHover Origin} s  -- First set the Origin flag 

579 |         in 

580 |         setMol (setAbbreviation False l s.posId g s.mol) s

581 |     _   => s  -- If not hovering over a valid atom, do nothing

587 | navigate : Direction -> DrawState -> DrawState

588 | navigate d = {mol $= moveActive d}

590 | onKeyDown, onKeyUp : DrawSettings => String -> DrawState -> DrawState

591 | onKeyDown "Escape"     s = {mode := Select, mol $= clear} s

592 | onKeyDown "Delete"     s = delete s

593 | onKeyDown "Shift"      s = {modifier := Shift} s

594 | onKeyDown "Control"    s = {modifier := Ctrl, mode $= startTemplRot s} s

595 | onKeyDown "Meta"       s = {modifier := Ctrl, mode $= startTemplRot s} s

596 | onKeyDown "ArrowUp"    s = ifCtrl (modAtom {elem $= incIso}) (navigate N) s

597 | onKeyDown "ArrowDown"  s = ifCtrl (modAtom {elem $= decIso}) (navigate S) s

598 | onKeyDown "ArrowRight" s = navigate E s

599 | onKeyDown "ArrowLeft"  s = navigate W s

600 | onKeyDown "+"          s = ifCtrl (zoomIn True) (modAtom {charge $= incCharge}) s

601 | onKeyDown "-"          s = ifCtrl (zoomOut True) (modAtom {charge $= decCharge}) s

602 | onKeyDown "c"          s = ifCtrl id (setElemStr "C") s

603 | onKeyDown "x"          s = ifCtrl delete (setElemStr "X") s

604 | onKeyDown "z"          s = ifCtrl undo (setElemStr "Z") s

605 | onKeyDown "y"          s = ifCtrl redo (setElemStr "Y") s

606 | onKeyDown "0"          s = addAbbrShortcut "Ph" phenyl s

607 | onKeyDown "1"          s = addBondShortcut False Single NoBondStereo s

608 | onKeyDown "2"          s = addBondShortcut False Dbl NoBondStereo s

609 | onKeyDown "3"          s = addBondShortcut False Triple NoBondStereo s

610 | onKeyDown "4"          s = addGroupShortcut phenyl s True

611 | onKeyDown "5"          s = addGroupShortcut (ring 5) s True

612 | onKeyDown "6"          s = addGroupShortcut (readMolfile cy) s True

613 | onKeyDown "7"          s = addBondShortcut True Single Up s 

614 | onKeyDown "8"          s = addBondShortcut True Single Down s

615 | onKeyDown "9"          s = addGroupShortcut (readMolfile ac) s False

616 | onKeyDown x            s = setElemStr (toUpper x) s

618 | onKeyUp "Shift"        s = {modifier $= reset Shift} s

619 | onKeyUp "Control"      s = {modifier $= reset Ctrl, mode $= stopTemplRot s} s

620 | onKeyUp "Meta"         s = {modifier $= reset Ctrl, mode $= stopTemplRot s} s

621 | onKeyUp _              s = s

623 | enableAbbr : DrawState -> DrawState

624 | enableAbbr s =

625 |   case s.abbr of

626 |     Nothing => s

627 |     Just a => {mode := SetAbbr a, mol $= clear} s

629 | setMassNr : Maybe MassNr -> MolAtomAT -> MolAtomAT

630 | setMassNr m a = let MkI e _ := a.elem in {elem := MkI e m} a

632 | erase : DrawState -> DrawState

633 | erase s =

634 |   case selectedItems s.imol of

635 |     None => {mode := Erase} s

636 |     _    => delete s

640 | trulyDifferent : SceneDims -> SceneDims -> Bool

641 | trulyDifferent (SD w1 h1) (SD w2 h2) = abs (w1-w2) >= 5 || abs (h1-h2) >= 5 

643 | endResize : (h,w : Double) -> DrawState -> DrawState

644 | endResize h w s =

645 |   let sd := if h > 2 && w > 2 then SD {sheight = h - 2, swidth = w - 2} else s.dims

646 |    in if trulyDifferent s.dims sd then {dims := sd} s else s

648 | upd : DrawSettings => DrawEvent -> DrawState -> DrawState

649 | upd (ZoomIn b)    s = zoomIn b s

650 | upd (ZoomOut b)   s = zoomOut b s

651 | upd LeftDown      s = leftDown s

652 | upd LeftUp        s = leftUp s

653 | upd (Move x y)    s = move s (P x y)

654 | upd MiddleDown    s = {mode $= Translating} s

655 | upd MiddleUp      s = {mode $= endTranslate} s

656 | upd Undo          s = undo s

657 | upd Redo          s = redo s

658 | upd (SetElem e)   s = {mode := SetAtom (cast e), mol $= clear} s

659 | upd (ChgElem v)   s = modAtomWhere (is Selected) {elem := cast v, charge := 0} s

660 | upd (ChgCharge v) s = modAtomWhere (is Selected) {charge := v} s

661 | upd (ChgMass v)   s = modAtomWhere (is Selected) (setMassNr v) s

662 | upd (SetTempl e)  s = {mode := SetTempl e, mol $= clear} s

663 | upd (Load e)      s = initST s.dims Reset e

664 | upd (SetBond b)   s = {bond := b, mode := Draw, mol $= clear} s

665 | upd SelectMode    s = {mode := Select} s

666 | upd (KeyDown x)   s = onKeyDown x s

667 | upd (KeyUp x)     s = onKeyUp x s

668 | upd EraseMode     s = erase s

669 | upd Focus         s = {hasFocus := True} s

670 | upd Blur          s = {hasFocus := False} s

671 | upd Clear         s = setMol (G 0 empty) s

672 | upd Expand        s = updateMol expand s

673 | upd Center        s = reset s

674 | upd EnableAbbr    s = enableAbbr s

675 | upd (SelAbbr a)   s = {mode := SetAbbr a, abbr := Just a, mol $= clear} s

676 | upd (Resize h w)  s = endResize h w s

677 | upd StartPSE      s = {mode := PTable Nothing} s

678 | upd SVG           s = s

679 | upd SVGimp        s = s

680 | upd Redraw        s = s

685 | toTransform : AffineTransformation -> Transform

686 | toTransform (AT (LT s r) (V x y)) =

687 |   let co  := s.value * cos r.value

688 |       si  := s.value * sin r.value

689 |    in Matrix co si (negate si) co x y

691 | scene : DrawSettings => (exp : Bool) -> DrawState -> SVGNode

692 | scene exp s =

693 |   case s.mode of

694 |     PTable me => displayPSE s.dims me

695 |     _         =>

696 |       let m := nextMol s

697 |        in g

698 |             [transform $ toTransform s.transform]

699 |             (if exp

700 |                then drawMolecule $ clear m

701 |                else drawMolecule m ++ drawSelection s)

706 | metadata : DrawSettings => DrawState -> (comment : String) -> SVGNode

707 | metadata s c =

708 |   let m := nextMol s

709 |    in El "metadata" [] [Txt $ toMolStr s c]

711 | display :

712 |      {auto _ : DrawSettings}

713 |   -> DrawState

714 |   -> (metadata : Bool)

715 |   -> (comment : String)

716 |   -> SVGNode

717 | display s m c =

718 |   svg

719 |     [ xmlns_2000

720 |     , width 100.perc

721 |     , height 100.perc

722 |     , viewBox 0.u 0.u s.dims.swidth.u s.dims.sheight.u

723 |     ] $ if m then [scene True s, metadata s c] else [scene False s]

726 | update : DrawSettings => DrawEvent -> DrawState -> DrawState

727 | update e s =

728 |   let s2 := upd e s

729 |    in {prevSVG := s.curSVG, curSVG := render (display s2 False "")} s2

735 | parameters {auto ds : DrawSettings}

737 |   ||| Initializes the drawing state for the given mol graph.

743 |   export

744 |   initMol :

745 |        SceneDims

746 |     -> ScaleMode

747 |     -> (metadata : Bool)

748 |     -> (comment : String)

749 |     -> CDGraph

750 |     -> DrawState

751 |   initMol sd sm metadata c g =

752 |     let s := initST sd sm g

753 |      in {curSVG := render (display s metadata c)} s

754 |   

755 |   export %inline

756 |   init : SceneDims -> ScaleMode -> String -> DrawState

757 |   init sd sm = initMol sd sm False "" . readMolfile

758 |   

759 |   export %inline

760 |   fromMol : SceneDims -> ScaleMode -> MolGraphAT -> DrawState

761 |   fromMol sd sm = initMol sd sm False "" . initGraph

763 |   ||| Generates a string holding the SVG-encoded molecular structur

769 |   export

770 |   exportSVGPair :

771 |        (metadata : Bool)

772 |     -> (comment : String)

773 |     -> DrawState

774 |     -> (SceneDims, String)

775 |   exportSVGPair b c s =

776 |     let Just (p1,p2) := corners $ bounds s.mol | Nothing => (SD 0 0, "")

777 |         (SZ _ _ r1 r2) := selectZones (convert p1) (convert p2)

778 |         sd             := SD (r2-r1).x (r2-r1).y

779 |      in (sd, curSVG $ initMol sd Init b c s.mol)

781 |   ||| Generates an SVG string out of the current DrawState. The

785 |   export

786 |   exportSVG : DrawState -> String

787 |   exportSVG = snd . exportSVGPair True ""