diff --git a/.github/linters/.ecrc b/.github/linters/.ecrc
new file mode 100644
index 0000000..b682057
--- /dev/null
+++ b/.github/linters/.ecrc
@@ -0,0 +1,5 @@
+{
+ "Disable": {
+ "IndentSize": true
+ }
+}
diff --git a/.github/workflows/ci-lib.yml b/.github/workflows/ci-lib.yml
new file mode 100644
index 0000000..ce47da2
--- /dev/null
+++ b/.github/workflows/ci-lib.yml
@@ -0,0 +1,33 @@
+---
+name: Build
+
+on:
+ push:
+ branches:
+ - '**'
+ tags:
+ - '**'
+ pull_request:
+ branches:
+ - main
+
+defaults:
+ run:
+ shell: bash
+
+jobs:
+ build:
+ name: Build ${{ github.repository }} with Idris2 latest
+ runs-on: ubuntu-latest
+ env:
+ PACK_DIR: /root/.pack
+ strategy:
+ fail-fast: false
+ container: ghcr.io/stefan-hoeck/idris2-pack:latest
+ steps:
+ - name: Checkout
+ uses: actions/checkout@v2
+ - name: Build lib
+ run: pack typecheck cyby-draw
+ - name: Build app
+ run: pack build cyby-draw-app
diff --git a/.github/workflows/ci-super-linter.yml b/.github/workflows/ci-super-linter.yml
new file mode 100644
index 0000000..4aaf5c2
--- /dev/null
+++ b/.github/workflows/ci-super-linter.yml
@@ -0,0 +1,33 @@
+---
+name: Lint
+
+on:
+ push:
+ branches:
+ - '*'
+ tags:
+ - '*'
+ pull_request:
+ branches:
+ - main
+ - master
+
+jobs:
+ build:
+ name: Lint Code Base
+ runs-on: ubuntu-latest
+ steps:
+
+ - name: Checkout
+ uses: actions/checkout@v2
+ with:
+ # Full git history is needed to get a proper list of changed files within `super-linter`
+ fetch-depth: 0
+
+ - name: Lint Code Base
+ uses: github/super-linter/slim@v4
+ env:
+ VALIDATE_ALL_CODEBASE: false
+ DEFAULT_BRANCH: main
+ GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+ IGNORE_GENERATED_FILES: true
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..880ac59
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+build/
+.DS_Store
diff --git a/README.md b/README.md
index 4318af6..a3ceeb4 100644
--- a/README.md
+++ b/README.md
@@ -1,2 +1,2 @@
# idris2-cyby-draw
-A chemical drawing tool for the browser
+A drawing tool for the browser written in Idris2
diff --git a/app.html b/app.html
new file mode 100644
index 0000000..f742133
--- /dev/null
+++ b/app.html
@@ -0,0 +1,13 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/app/cyby-draw-app.ipkg b/app/cyby-draw-app.ipkg
new file mode 100644
index 0000000..f2f87ca
--- /dev/null
+++ b/app/cyby-draw-app.ipkg
@@ -0,0 +1,12 @@
+package cyby-draw-app
+
+authors = "claudio-etterli, stefan-hoeck"
+version = 0.1.0
+sourcedir = "src"
+depends = cyby-draw
+ , pretty-show
+
+opts = "--codegen javascript"
+
+main = Main
+executable = "cyby-draw-app.js"
diff --git a/app/src/Debug.idr b/app/src/Debug.idr
new file mode 100644
index 0000000..0c320d6
--- /dev/null
+++ b/app/src/Debug.idr
@@ -0,0 +1,103 @@
+module Debug
+
+import CyBy.Draw
+import Data.List1
+import Data.String
+import Derive.Prelude
+import Geom
+import Text.Lex.Manual
+import Text.Show.Pretty
+import Web.MVC
+
+%default total
+%language ElabReflection
+
+export
+debugInfo : DrawEvent -> DrawState -> String
+debugInfo e s =
+ """
+ Current Event: \{show e}
+ """
+
+--------------------------------------------------------------------------------
+-- Molecule and Atom Info
+--------------------------------------------------------------------------------
+
+-- a monoid for accumulating information about molecules
+record Info where
+ constructor I
+ formula : Formula
+ mass : MolecularMass
+ exactMass : MolecularMass
+
+%runElab derive "Info" [Show,Eq,Semigroup,Monoid]
+
+toMass : Double -> MolecularMass
+toMass = fromMaybe 1.0e60 . refineMolecularMass
+
+info : CDAtom -> Info
+info (CA _ a) = I (cast a) (molecularMass a) (exactMolecularMass a)
+
+formula : Formula -> List (Node DrawEvent)
+formula (F ps) = pairs ps >>= dispPair
+ where
+ dispPair : (Elem,Nat) -> List (Node DrawEvent)
+ dispPair (e,1) = [span [class "formula_elem"] [Text $ symbol e]]
+ dispPair (e,n) =
+ [ span [class "formula_elem"] [Text $ symbol e]
+ , span [class "formula_count"] [Text $ show n]
+ ]
+
+infoEntry : String -> List (Node DrawEvent) -> List (Node DrawEvent)
+infoEntry l s =
+ [ div [class "info_label"] [Text l]
+ , div [class "info_value"] s
+ ]
+
+infoStr : String -> String -> List (Node DrawEvent)
+infoStr l = infoEntry l . pure . Text
+
+iso : Maybe MassNr -> String
+iso = maybe "Mix" (show . value)
+
+bondType : BondType -> String
+bondType Dbl = "double"
+bondType x = toLower $ show x
+
+neighbour : Fin k -> MolBond -> List (Node DrawEvent)
+neighbour n b =
+ [ div [class "neighbour_index"] [Text $ show n]
+ , div [class "neighbour_type"] [Text $ bondType b.type]
+ ]
+
+neighbours : AssocList k CDBond -> Node DrawEvent
+neighbours ns =
+ div [class "neighbours"] $ pairs ns >>= \(n,b) => neighbour n b.molBond
+
+
+atomDetails : CDGraph -> List (Node DrawEvent)
+atomDetails (G _ g) =
+ case find (is Hover) (contexts g) of
+ Just (C n (CA _ a) ns) =>
+ join
+ [ infoStr "Element" (symbol a.elem.elem)
+ , infoStr "Isotope" (iso a.elem.mass)
+ , infoStr "Charge" (show a.charge.value)
+ , infoStr "Implicit hydrogens" (show a.hydrogen.value)
+ , infoStr "Atom type" a.type.name
+ , infoStr "Index" (show n)
+ , infoEntry "Neighbours" . pure $ neighbours ns
+ ]
+ Nothing => []
+
+export
+molDetails : CDGraph -> List (Node DrawEvent)
+molDetails (G 0 _) = []
+molDetails g =
+ let I f m em := foldMap info g
+ in join
+ [ infoEntry "Formula" (formula f)
+ , infoStr "Mass" "\{printDouble 3 m.value} g/mol"
+ , infoStr "Exact mass" "\{printDouble 7 em.value} g/mol"
+ , atomDetails g
+ ]
diff --git a/app/src/Html.idr b/app/src/Html.idr
new file mode 100644
index 0000000..58dcc99
--- /dev/null
+++ b/app/src/Html.idr
@@ -0,0 +1,37 @@
+module Html
+
+import CyBy.Draw
+import Data.List
+import Text.Molfile
+import Text.CSS.Color
+import Web.MVC
+import Text.SVG
+
+%default total
+
+export
+messages : Ref Div
+messages = Id "messages"
+
+printMsg : DrawMsg -> String
+printMsg Copied = "Structure copied to clipboard"
+printMsg (ReadErr str) = "Error when pasting structure: \{str}"
+
+clearMsg : DrawEvent -> Cmd DrawEvent
+clearMsg (KeyUp str) = neutral
+clearMsg _ = children messages []
+
+logAndDisplay : DrawSettings => DrawEvent -> DrawState -> Cmd DrawEvent
+logAndDisplay (Msg m) s = child messages $ Text (printMsg m)
+logAndDisplay e s = clearMsg e <+> displaySketcher "app" e s
+
+covering export
+app : IO ()
+app =
+ let se := defaultSettings abbreviations
+ in runMVC
+ update
+ (logAndDisplay @{se})
+ (putStrLn . dispErr)
+ (KeyDown "Escape")
+ (init @{se} (SD 600 400) Init "")
diff --git a/app/src/Main.idr b/app/src/Main.idr
new file mode 100644
index 0000000..82277a1
--- /dev/null
+++ b/app/src/Main.idr
@@ -0,0 +1,6 @@
+module Main
+
+import Html
+
+main : IO ()
+main = app
diff --git a/css/cyby-draw.css b/css/cyby-draw.css
new file mode 100644
index 0000000..0a060e4
--- /dev/null
+++ b/css/cyby-draw.css
@@ -0,0 +1,339 @@
+/* Page */
+html {
+ height : 100%;
+ font-size : 10px;
+}
+
+body {
+ background-color : darkgrey;
+ color : black;
+ display : flex;
+ flex-direction : column;
+ font-family : "sans-serif";
+ height : 100%;
+ margin : 0px;
+}
+
+.cyby_draw_main_content {
+ display : grid;
+ grid-template-columns : max-content max-content;
+ column-gap : 10px;
+ background-color : darkgrey;
+ padding : 20px;
+}
+
+/* Buttons and Icons */
+
+.cyby_draw_btn {
+ text-align : center;
+ background-color : rgb(238,238,238);
+ border-radius : 2px
+}
+
+.cyby_draw_icon {
+ width : 20px;
+ height : 20px;
+ border : none;
+ background-size : 100%;
+ background-color : transparent;
+}
+
+.cyby_draw_icon:hover {
+ border-radius : 3px;
+ background-color : rgb(158,158,158);
+}
+
+.cyby_draw_icon:disabled {
+ opacity : 0.5;
+}
+
+.cyby_draw_icon:disabled:hover {
+ opacity : 0.5;
+ background-color : transparent;
+}
+
+.cyby_draw_radio_icon {
+ appearance : none;
+ width : 20px;
+ height : 20px;
+ border : none;
+ background-size : 100%;
+ margin : 0px;
+ border-radius : 3px;
+ border : 1px solid darkgrey;
+}
+
+.cyby_draw_radio_icon:checked {
+ border : 1px solid black;
+ background-color : rgb(189,189,189);
+}
+
+.cyby_draw_radio_icon:hover {
+ background-color : rgb(158,158,158);
+}
+
+
+/* Sketcher with Canvas and Buttons */
+.cyby_draw_sketcher_div {
+ background-color : rgb(238,238,238);
+ grid-column : 1;
+ grid-row : 1;
+ display : grid;
+ padding : 3px;
+ row-gap : 3px;
+ column-gap : 3px;
+ grid-template-columns : min-content 1fr min-content;
+ grid-template-rows : max-content 1fr max-content;
+ grid-template-areas : "top top dot"
+ "left draw right"
+ "left bot right";
+}
+
+.cyby_draw_toolbar_top {
+ display : grid;
+ grid-template-columns : repeat(15,min-content);
+ column-gap : 3px;
+ grid-area : top;
+}
+
+.cyby_draw_toolbar_left {
+ display : grid;
+ grid-template-rows : repeat(9,min-content);
+ row-gap : 3px;
+ grid-area : left;
+}
+
+.cyby_draw_toolbar_right {
+ display : grid;
+ grid-template-rows : repeat(3,max-content);
+ row-gap : 6px;
+ grid-area : right;
+}
+
+.cyby_draw_toolbar_bottom_outer {
+ display : grid;
+ grid-template-columns : repeat(2,min-content);
+ column-gap : 3px;
+ align-items : center;
+ grid-area : bot;
+}
+
+.cyby_draw_toolbar_bottom_inner {
+ display : grid;
+ grid-template-columns : repeat(7,min-content);
+ column-gap : 3px;
+}
+
+.cyby_draw_btn.reset {
+ justify-self : start;
+}
+
+.cyby_draw_info_label {
+ font-weight : bold
+}
+
+.cyby_draw_radio_icon.sel {
+ background-image : url('icons/icon_select.svg');
+}
+
+.cyby_draw_radio_icon.erase {
+ background-image : url('icons/icon_eraser.svg');
+}
+
+.cyby_draw_icon.clear {
+ background-image : url('icons/icon_trash.svg');
+}
+
+.cyby_draw_icon.undo {
+ background-image : url('icons/icon_undo.svg');
+}
+
+.cyby_draw_icon.redo {
+ background-image : url('icons/icon_redo.svg');
+}
+
+.cyby_draw_icon.zoomIn {
+ background-image : url('icons/icon_zoomIn.svg');
+}
+
+.cyby_draw_icon.center {
+ background-image : url('icons/icon_centering.svg');
+}
+
+.cyby_draw_icon.zoomOut {
+ background-image : url('icons/icon_zoomOut.svg');
+}
+
+.cyby_draw_radio_icon.benzene {
+ background-image : url('icons/icon_benzene.svg');
+}
+
+.cyby_draw_radio_icon.cyclopropane {
+ background-image : url('icons/icon_cyclopropane.svg');
+}
+
+.cyby_draw_radio_icon.cyclobutane {
+ background-image : url('icons/icon_cyclobutane.svg');
+}
+
+.cyby_draw_radio_icon.cyclopentane {
+ background-image : url('icons/icon_cyclopentane.svg');
+}
+
+.cyby_draw_radio_icon.cyclohexane {
+ background-image : url('icons/icon_cyclohexane.svg');
+}
+
+.cyby_draw_radio_icon.cycloheptane {
+ background-image : url('icons/icon_cycloheptane.svg');
+}
+
+.cyby_draw_radio_icon.cyclooctane {
+ background-image : url('icons/icon_cyclooctane.svg');
+}
+
+.cyby_draw_radio_icon.snglB {
+ background-image : url('icons/icon_snglB.svg');
+}
+
+.cyby_draw_radio_icon.snglBUp {
+ background-image : url('icons/icon_snglBUp.svg');
+}
+
+.cyby_draw_radio_icon.snglBDown {
+ background-image : url('icons/icon_snglBDown.svg');
+}
+
+.cyby_draw_radio_icon.snglBUpDown {
+ background-image : url('icons/icon_snglBUpDown.svg');
+}
+
+.cyby_draw_radio_icon.dblB {
+ background-image : url('icons/icon_dblB.svg');
+}
+
+.cyby_draw_radio_icon.trplB {
+ background-image : url('icons/icon_trplB.svg');
+}
+
+.cyby_draw_radio_icon.setC {
+ background-image : url('icons/icon_c.svg');
+}
+
+.cyby_draw_radio_icon.setN {
+ background-image : url('icons/icon_n.svg');
+}
+
+.cyby_draw_radio_icon.setO {
+ background-image : url('icons/icon_o.svg');
+}
+
+.cyby_draw_radio_icon.setS {
+ background-image : url('icons/icon_s.svg');
+}
+
+.cyby_draw_radio_icon.setF {
+ background-image : url('icons/icon_f.svg');
+}
+
+.cyby_draw_radio_icon.setP {
+ background-image : url('icons/icon_p.svg');
+}
+
+.cyby_draw_radio_icon.setB {
+ background-image : url('icons/icon_b.svg');
+}
+
+.cyby_draw_radio_icon.setCl {
+ background-image : url('icons/icon_cl.svg');
+}
+
+.cyby_draw_radio_icon.setBr {
+ background-image : url('icons/icon_br.svg');
+}
+
+.cyby_draw_radio_icon.pse {
+ background-image : url('icons/icon_pse.svg');
+}
+
+.cyby_draw_icon.toggleMol {
+ background-image : url('icons/icon_folder.svg');
+}
+
+.cyby_draw_molecule_canvas {
+ background-color : white;
+ border : 1px solid white;
+ border-radius : 3px;
+ grid-area : draw;
+ justify-self : center;
+ overflow : hidden;
+ resize : both;
+}
+
+.cyby_draw_molecule_canvas:focus {
+ border : 1px solid black;
+}
+
+.cyby_draw_molecule_canvas.rotating {
+ cursor : url('icons/icon_rotation.svg'), auto;
+}
+
+.cyby_draw_molecule_canvas.dragging {
+ cursor : move;
+}
+
+
+/* Debug Information of the drawn molecule */
+.cyby_draw_info_list {
+ display : grid;
+ grid-template-columns : 150px max-content;
+ grid-auto-rows : max-content;
+ row-gap : 10px
+}
+
+.cyby_draw_formula_count {
+ font-variant-position: sub
+}
+
+.cyby_draw_neighbours {
+ display : grid;
+ grid-template-columns : max-content max-content;
+ column-gap : 3px
+}
+
+.cyby_draw_neighbour_index {
+ text-align : right;
+}
+
+.cyby_draw_neighbour_type {
+}
+
+
+.cyby_draw_detail {
+ display : grid;
+ grid-template-rows : max-content max-content;
+ row-gap : 2px;
+}
+
+.cyby_draw_label {
+ font-size : 1.1rem;
+}
+
+.cyby_draw_select {
+ font-size : 1.1rem;
+ height : 20px;
+ padding-top : 0px;
+ padding-bottom : 0px;
+}
+
+.cyby_draw_select.active {
+ border-radius : 3px;
+ border : 1px solid black;
+ background-color : rgb(189,189,189);
+}
+
+
+/* Util */
+.hidden {
+ display : none;
+}
diff --git a/css/icons/icon_Mol.svg b/css/icons/icon_Mol.svg
new file mode 100644
index 0000000..cfd18f9
--- /dev/null
+++ b/css/icons/icon_Mol.svg
@@ -0,0 +1,14 @@
+
+
diff --git a/css/icons/icon_b.svg b/css/icons/icon_b.svg
new file mode 100644
index 0000000..c41756c
--- /dev/null
+++ b/css/icons/icon_b.svg
@@ -0,0 +1,45 @@
+
+
diff --git a/css/icons/icon_benzene.svg b/css/icons/icon_benzene.svg
new file mode 100644
index 0000000..4922536
--- /dev/null
+++ b/css/icons/icon_benzene.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_br.svg b/css/icons/icon_br.svg
new file mode 100644
index 0000000..8c11c60
--- /dev/null
+++ b/css/icons/icon_br.svg
@@ -0,0 +1,45 @@
+
+
diff --git a/css/icons/icon_c.svg b/css/icons/icon_c.svg
new file mode 100644
index 0000000..9dd2a07
--- /dev/null
+++ b/css/icons/icon_c.svg
@@ -0,0 +1,57 @@
+
+
diff --git a/css/icons/icon_centering.svg b/css/icons/icon_centering.svg
new file mode 100644
index 0000000..b29161a
--- /dev/null
+++ b/css/icons/icon_centering.svg
@@ -0,0 +1,10 @@
+
+
diff --git a/css/icons/icon_cl.svg b/css/icons/icon_cl.svg
new file mode 100644
index 0000000..681c482
--- /dev/null
+++ b/css/icons/icon_cl.svg
@@ -0,0 +1,45 @@
+
+
diff --git a/css/icons/icon_copy.svg b/css/icons/icon_copy.svg
new file mode 100644
index 0000000..64fb88d
--- /dev/null
+++ b/css/icons/icon_copy.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_cyclobutane.svg b/css/icons/icon_cyclobutane.svg
new file mode 100644
index 0000000..98f48e1
--- /dev/null
+++ b/css/icons/icon_cyclobutane.svg
@@ -0,0 +1,50 @@
+
+
diff --git a/css/icons/icon_cycloheptane.svg b/css/icons/icon_cycloheptane.svg
new file mode 100644
index 0000000..3552f86
--- /dev/null
+++ b/css/icons/icon_cycloheptane.svg
@@ -0,0 +1,51 @@
+
+
diff --git a/css/icons/icon_cyclohexane.svg b/css/icons/icon_cyclohexane.svg
new file mode 100644
index 0000000..7dbfe21
--- /dev/null
+++ b/css/icons/icon_cyclohexane.svg
@@ -0,0 +1,50 @@
+
+
diff --git a/css/icons/icon_cyclooctane.svg b/css/icons/icon_cyclooctane.svg
new file mode 100644
index 0000000..7ea2022
--- /dev/null
+++ b/css/icons/icon_cyclooctane.svg
@@ -0,0 +1,50 @@
+
+
diff --git a/css/icons/icon_cyclopentane.svg b/css/icons/icon_cyclopentane.svg
new file mode 100644
index 0000000..356ef66
--- /dev/null
+++ b/css/icons/icon_cyclopentane.svg
@@ -0,0 +1,51 @@
+
+
diff --git a/css/icons/icon_cyclopropane.svg b/css/icons/icon_cyclopropane.svg
new file mode 100644
index 0000000..07de25f
--- /dev/null
+++ b/css/icons/icon_cyclopropane.svg
@@ -0,0 +1,51 @@
+
+
diff --git a/css/icons/icon_dblB.svg b/css/icons/icon_dblB.svg
new file mode 100644
index 0000000..a3edc25
--- /dev/null
+++ b/css/icons/icon_dblB.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_eraser.svg b/css/icons/icon_eraser.svg
new file mode 100644
index 0000000..eec972c
--- /dev/null
+++ b/css/icons/icon_eraser.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_f.svg b/css/icons/icon_f.svg
new file mode 100644
index 0000000..4e30069
--- /dev/null
+++ b/css/icons/icon_f.svg
@@ -0,0 +1,45 @@
+
+
diff --git a/css/icons/icon_folder.svg b/css/icons/icon_folder.svg
new file mode 100644
index 0000000..fddec97
--- /dev/null
+++ b/css/icons/icon_folder.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_hexMol.svg b/css/icons/icon_hexMol.svg
new file mode 100644
index 0000000..ef34ee9
--- /dev/null
+++ b/css/icons/icon_hexMol.svg
@@ -0,0 +1,19 @@
+
+
diff --git a/css/icons/icon_hexMol2.svg b/css/icons/icon_hexMol2.svg
new file mode 100644
index 0000000..f4a9c7e
--- /dev/null
+++ b/css/icons/icon_hexMol2.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_lasso.svg b/css/icons/icon_lasso.svg
new file mode 100644
index 0000000..cd192e5
--- /dev/null
+++ b/css/icons/icon_lasso.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_n.svg b/css/icons/icon_n.svg
new file mode 100644
index 0000000..ab48fa2
--- /dev/null
+++ b/css/icons/icon_n.svg
@@ -0,0 +1,39 @@
+
+
diff --git a/css/icons/icon_o.svg b/css/icons/icon_o.svg
new file mode 100644
index 0000000..18b7926
--- /dev/null
+++ b/css/icons/icon_o.svg
@@ -0,0 +1,17 @@
+
+
diff --git a/css/icons/icon_p.svg b/css/icons/icon_p.svg
new file mode 100644
index 0000000..d83c8ee
--- /dev/null
+++ b/css/icons/icon_p.svg
@@ -0,0 +1,45 @@
+
+
diff --git a/css/icons/icon_pse.svg b/css/icons/icon_pse.svg
new file mode 100644
index 0000000..a760b0f
--- /dev/null
+++ b/css/icons/icon_pse.svg
@@ -0,0 +1,45 @@
+
+
diff --git a/css/icons/icon_redo.svg b/css/icons/icon_redo.svg
new file mode 100644
index 0000000..ea82817
--- /dev/null
+++ b/css/icons/icon_redo.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_rotation.svg b/css/icons/icon_rotation.svg
new file mode 100644
index 0000000..a7d7ebe
--- /dev/null
+++ b/css/icons/icon_rotation.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_s.svg b/css/icons/icon_s.svg
new file mode 100644
index 0000000..b16bc62
--- /dev/null
+++ b/css/icons/icon_s.svg
@@ -0,0 +1,57 @@
+
+
diff --git a/css/icons/icon_select.svg b/css/icons/icon_select.svg
new file mode 100644
index 0000000..7464b61
--- /dev/null
+++ b/css/icons/icon_select.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_snglB.svg b/css/icons/icon_snglB.svg
new file mode 100644
index 0000000..616548d
--- /dev/null
+++ b/css/icons/icon_snglB.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_snglBDown.svg b/css/icons/icon_snglBDown.svg
new file mode 100644
index 0000000..498fa91
--- /dev/null
+++ b/css/icons/icon_snglBDown.svg
@@ -0,0 +1,85 @@
+
+
diff --git a/css/icons/icon_snglBUp.svg b/css/icons/icon_snglBUp.svg
new file mode 100644
index 0000000..fab71e7
--- /dev/null
+++ b/css/icons/icon_snglBUp.svg
@@ -0,0 +1,36 @@
+
+
diff --git a/css/icons/icon_snglBUpDown.svg b/css/icons/icon_snglBUpDown.svg
new file mode 100644
index 0000000..4dc270c
--- /dev/null
+++ b/css/icons/icon_snglBUpDown.svg
@@ -0,0 +1,100 @@
+
+
diff --git a/css/icons/icon_trash.svg b/css/icons/icon_trash.svg
new file mode 100644
index 0000000..9a9058f
--- /dev/null
+++ b/css/icons/icon_trash.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_trplB.svg b/css/icons/icon_trplB.svg
new file mode 100644
index 0000000..94ce83f
--- /dev/null
+++ b/css/icons/icon_trplB.svg
@@ -0,0 +1,52 @@
+
+
diff --git a/css/icons/icon_undo.svg b/css/icons/icon_undo.svg
new file mode 100644
index 0000000..ad1e566
--- /dev/null
+++ b/css/icons/icon_undo.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_zoomIn.svg b/css/icons/icon_zoomIn.svg
new file mode 100644
index 0000000..111b2cd
--- /dev/null
+++ b/css/icons/icon_zoomIn.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/icon_zoomOut.svg b/css/icons/icon_zoomOut.svg
new file mode 100644
index 0000000..ae39b45
--- /dev/null
+++ b/css/icons/icon_zoomOut.svg
@@ -0,0 +1,6 @@
+
+
diff --git a/css/icons/source.txt b/css/icons/source.txt
new file mode 100644
index 0000000..9be1961
--- /dev/null
+++ b/css/icons/source.txt
@@ -0,0 +1,27 @@
+svgrepo.com
+collection : calcite sharp line icons
+icons : - lasso select svg vector
+ - cursor marquee svg vector
+ - Magnifying Glass Minus SVG Vector
+ - Magnifying Glass Plus SVG Vector
+ - Trash SVG Vector
+ - Folder Open SVG Vector
+ - Copy SVG Vector
+
+collection : neuicons oval line icons
+icons : - line svg vector
+
+collection : bootstrap UI icons
+icons : - eraser svg vector
+
+collection : dazzle line icons
+icons : - Grip Lines Vertical SVG Vector (turned)
+
+collection : science icons
+icons : - Molecule Hexagonal Shapes SVG
+
+collection : college
+icons : - Hexagonal Molecule SVG Vector
+
+collection : science study
+icons : - Molecule SVG Vector
diff --git a/cyby-draw.ipkg b/cyby-draw.ipkg
new file mode 100644
index 0000000..17fef00
--- /dev/null
+++ b/cyby-draw.ipkg
@@ -0,0 +1,33 @@
+package cyby-draw
+
+authors = "claudio-etterli, stefan-hoeck"
+version = 0.1.0
+sourcedir = "src"
+depends = base >= 0.6.0
+ , chem
+ , dom
+ , dom-mvc
+ , containers
+ , svg
+
+modules = CyBy.Draw
+
+ , CyBy.Draw.Internal.Abbreviations
+ , CyBy.Draw.Internal.Atom
+ , CyBy.Draw.Internal.CoreDims
+ , CyBy.Draw.Internal.DoubleBond
+ , CyBy.Draw.Internal.Color
+ , CyBy.Draw.Internal.Graph
+ , CyBy.Draw.Internal.Label
+ , CyBy.Draw.Internal.Ring
+ , CyBy.Draw.Internal.Role
+ , CyBy.Draw.Internal.Settings
+ , CyBy.Draw.Internal.Wedge
+
+ , CyBy.Draw.Draw
+ , CyBy.Draw.Event
+ , CyBy.Draw.MoleculeCanvas
+ , CyBy.Draw.PeriodicTableCanvas
+ , CyBy.Draw.Residue
+
+ , Text.Measure
diff --git a/pack.toml b/pack.toml
new file mode 100644
index 0000000..e0c3ce5
--- /dev/null
+++ b/pack.toml
@@ -0,0 +1,45 @@
+[custom.all.cyby-draw]
+type = "local"
+path = "."
+ipkg = "cyby-draw.ipkg"
+
+[custom.all.cyby-draw-app]
+type = "local"
+path = "app"
+ipkg = "cyby-draw-app.ipkg"
+
+[custom.all.chem]
+type = "git"
+url = "https://github.com/stefan-hoeck/idris2-chem"
+commit = "latest:main"
+ipkg = "chem.ipkg"
+
+[custom.all.chem-generators]
+type = "git"
+url = "https://github.com/stefan-hoeck/idris2-chem"
+commit = "latest:main"
+ipkg = "chem-generators/chem-generators.ipkg"
+
+[custom.all.ref1]
+type = "git"
+url = "https://github.com/stefan-hoeck/idris2-ref1"
+commit = "latest:main"
+ipkg = "ref1.ipkg"
+
+[custom.all.array]
+type = "git"
+url = "https://github.com/stefan-hoeck/idris2-array"
+commit = "latest:main"
+ipkg = "array.ipkg"
+
+[custom.all.bytestring]
+type = "git"
+url = "https://github.com/stefan-hoeck/idris2-bytestring"
+commit = "latest:main"
+ipkg = "bytestring.ipkg"
+
+[custom.all.indexed-graph]
+type = "git"
+url = "https://github.com/stefan-hoeck/idris2-indexed-graph"
+commit = "latest:main"
+ipkg = "indexed-graph.ipkg"
diff --git a/resource/font.py b/resource/font.py
new file mode 100644
index 0000000..c8e2968
--- /dev/null
+++ b/resource/font.py
@@ -0,0 +1,27 @@
+import string
+
+from PIL import ImageFont
+
+WIDTH_DICT = dict()
+
+supported_chars = [c for c in string.printable if not c.isspace() or c == ' ']
+
+
+font_file_path = "/urs/share/fonts/liberation/LiberationSans-Regular.ttf"
+font = ImageFont.truetype(font_file_path, 500)
+
+for char in supported_chars:
+ left, _, right, _ = font.getbbox(char)
+ width = right - left
+ WIDTH_DICT[char] = width
+
+
+AVERAGE_WIDTH = sum(WIDTH_DICT.values()) / len(WIDTH_DICT)
+
+print(f'{WIDTH_DICT=}')
+print(f'{AVERAGE_WIDTH=}')
+
+def get_width_liberation_sans(string, size) :
+ return sum(WIDTH_DICT.get(s, AVERAGE_WIDTH) for s in string) * size / 500
+
+print(get_width_liberation_sans("The quick brown fox jumps over the lazy dog.", 15))
diff --git a/src/CyBy/Draw.idr b/src/CyBy/Draw.idr
new file mode 100644
index 0000000..44ca515
--- /dev/null
+++ b/src/CyBy/Draw.idr
@@ -0,0 +1,454 @@
+module CyBy.Draw
+
+import Data.Finite
+import Data.List
+import Geom
+import Text.HTML.Select
+import Text.SVG
+import Web.Html
+import Web.MVC
+import Web.MVC.Util
+import Web.MVC.View
+
+import CyBy.Draw.Internal.Label
+import public CyBy.Draw.Draw
+import public CyBy.Draw.Event
+import public CyBy.Draw.Internal.Abbreviations
+import public CyBy.Draw.Internal.Atom
+import public CyBy.Draw.Internal.CoreDims
+import public CyBy.Draw.Internal.Graph
+import public CyBy.Draw.Internal.Ring
+import public CyBy.Draw.Internal.Role
+import public CyBy.Draw.Internal.Settings
+import public CyBy.Draw.MoleculeCanvas
+import public CyBy.Draw.PeriodicTableCanvas
+import public Text.Molfile
+
+%default total
+
+%foreign "browser:lambda:(s,w) => navigator.clipboard.writeText(s)"
+prim__writeToClipboard : String -> PrimIO ()
+
+%foreign "browser:lambda:(f,w) => navigator.clipboard.readText().then(s => f(s)(w))"
+prim__readFromClipboard : (String -> PrimIO ()) -> PrimIO ()
+
+molToClipboard : CDGraph -> JSIO ()
+molToClipboard g = primIO (prim__writeToClipboard . writeMolfile $ toMolfile g)
+
+fromClipboard : Cmd DrawEvent
+fromClipboard =
+ C $ \h => primIO $ prim__readFromClipboard $ \s,w =>
+ case readMolfileE s of
+ Left s => toPrim (runJS $ h (Msg $ ReadErr s)) w
+ Right g => toPrim (runJS $ h (SetTempl g)) w
+
+--------------------------------------------------------------------------------
+-- Events
+--------------------------------------------------------------------------------
+
+down : MouseInfo -> Maybe DrawEvent
+down mi = case mi.button of
+ 0 => Just LeftDown
+ 1 => Just MiddleDown
+ _ => Nothing
+
+up : MouseInfo -> Maybe DrawEvent
+up mi = case mi.button of
+ 0 => Just LeftUp
+ 1 => Just MiddleUp
+ _ => Nothing
+
+move : MouseInfo -> Maybe DrawEvent
+move x = Just $ Move x.offsetX x.offsetY
+
+bool : String -> Bool
+bool "true" = True
+bool _ = False
+
+wheel : WheelInfo -> Maybe DrawEvent
+wheel wi =
+ if wi.deltaY < 0 then Just (ZoomIn True)
+ else if wi.deltaY > 0 then Just (ZoomOut True)
+ else Nothing
+
+--------------------------------------------------------------------------------
+-- IDs
+--------------------------------------------------------------------------------
+
+export
+moleculeCanvas : String -> Ref Div
+moleculeCanvas pre = Id "\{pre}_molecule_canvas"
+
+export
+sketcherDiv : String -> Ref Div
+sketcherDiv pre = Id "\{pre}_sketcher_div"
+
+export
+sketcherDivInner : String -> Ref Div
+sketcherDivInner pre = Id "\{pre}_sketcher_div_inner"
+
+export
+infoList : String -> Ref Div
+infoList pre = Id "\{pre}_info_list"
+
+export
+molReader : String -> Ref Div
+molReader pre = Id "\{pre}_mol_reader"
+
+export
+molInput : String -> Ref TextArea
+molInput pre = Id "\{pre}_mol_input"
+
+export
+leftBarID : String -> Ref Div
+leftBarID pre = Id "\{pre}_left_bar"
+
+export
+rightBarID : String -> Ref Div
+rightBarID pre = Id "\{pre}_right_bar"
+
+export
+topBarID : String -> Ref Div
+topBarID pre = Id "\{pre}_top_bar"
+
+export
+bottomBarID : String -> Ref Div
+bottomBarID pre = Id "\{pre}_bottom_bar"
+
+export
+abbrID : String -> Ref Tag.Select
+abbrID pre = Id "\{pre}_abbreviations"
+
+--------------------------------------------------------------------------------
+-- View
+--------------------------------------------------------------------------------
+
+elems : MolAtomAT -> Node DrawEvent
+elems a =
+ selectFromListBy values (a.elem.elem ==) symbol ChgElem
+ [ class "cyby_draw_select", title "Set Element" ]
+
+charges : MolAtomAT -> Node DrawEvent
+charges a =
+ selectFromListBy chs (a.charge ==) (show . value) ChgCharge
+ [ class "cyby_draw_select", title "Set Charge" ]
+ where
+ chs : List Charge
+ chs = mapMaybe refineCharge [(-8) .. 8]
+
+massNrs : MolAtomAT -> Node DrawEvent
+massNrs a =
+ selectFromListBy (masses a.elem.elem) (a.elem.mass ==) dispMass ChgMass
+ [ class "cyby_draw_select", title "Set Charge" ]
+ where
+ dispMass : Maybe MassNr -> String
+ dispMass Nothing = "Mix"
+ dispMass (Just m) = show m.value
+
+hidden : {0 t : _} -> Attribute t e
+hidden = class "hidden"
+
+icon : (cls : String) -> DrawEvent -> (title : String) -> Node DrawEvent
+icon cls ev ttl =
+ button [classes ["cyby_draw_icon", cls], onClick ev, title ttl] []
+
+radioIcon :
+ (cls : String)
+ -> DrawEvent
+ -> (title : String)
+ -> Bool
+ -> Node DrawEvent
+radioIcon cls ev ttl b =
+ input
+ [ name "tool"
+ , type Radio
+ , classes ["cyby_draw_radio_icon", cls]
+ , onClick ev, title ttl
+ , checked b
+ ]
+ []
+
+abbrCls : DrawState -> List String
+abbrCls s =
+ case s.mode of
+ SetAbbr _ => ["cyby_draw_select","active"]
+ _ => ["cyby_draw_select"]
+
+
+abbrs : (ds : DrawSettings) => (pre : String) -> DrawState -> Node DrawEvent
+abbrs pre s =
+ selectFromListBy
+ ds.abbreviations
+ (\a => any ((a.label ==) . label) s.abbr)
+ label
+ SelAbbr
+ [ Id $ abbrID pre
+ , classes $ abbrCls s
+ , title "Abbreviations"
+ , Event (MouseDown $ \mi => toMaybe (mi.button == 0) EnableAbbr)
+ ]
+
+drawing : MolBond -> DrawState -> Bool
+drawing b s =
+ (s.mode == Draw || s.mode == Drawing Nothing) &&
+ (s.bond == b)
+
+setting : Elem -> DrawState -> Bool
+setting el s = s.mode == SetAtom (cast el)
+
+bondIcon : String -> MolBond -> String -> DrawState -> Node DrawEvent
+bondIcon c b title = radioIcon c (SetBond b) title . drawing b
+
+%inline fromStereo : BondStereo -> MolBond
+fromStereo = MkBond True Single
+
+disable : Bool -> Node e -> Node e
+disable b = withAttribute (disabled b)
+
+minZoom : (s : DrawSettings) => AffineTransformation -> Bool
+minZoom (AT tf _) = tf.scale <= s.minZoom
+
+maxZoom : (s : DrawSettings) => AffineTransformation -> Bool
+maxZoom (AT tf _) = tf.scale >= s.maxZoom
+
+topBar : DrawSettings => (pre : String) -> DrawState -> Node DrawEvent
+topBar pre s =
+ div
+ [ Id $ topBarID pre, class "cyby_draw_toolbar_top" ]
+ [ radioIcon "sel" SelectMode "select" (s.mode == Select)
+ , radioIcon "erase" EraseMode "erase" (s.mode == Erase)
+ , disable (order s.mol == 0) $ icon "clear" Clear "clear"
+ , disable (s.undos == []) $ icon "undo" Undo "undo"
+ , disable (s.redos == []) $ icon "redo" Redo "redo"
+ , icon "center" Center "center"
+ , disable (maxZoom s.transform) $ icon "zoomIn" (ZoomIn False) "zoom in"
+ , disable (minZoom s.transform) $ icon "zoomOut" (ZoomOut False) "zoom out"
+ , bondIcon "snglB" (cast Single) "single bond" s
+ , bondIcon "snglBUp" (fromStereo Up) "single bond up" s
+ , bondIcon "snglBDown" (fromStereo Down) "single bond down" s
+ , bondIcon "snglBUpDown" (fromStereo UpOrDown) "single bond up or down" s
+ , bondIcon "dblB" (cast Dbl) "double bond" s
+ , bondIcon "trplB" (cast Triple) "triple bond" s
+ ]
+
+template : (cls : String) -> CDGraph -> String -> DrawState -> Node DrawEvent
+template cls g nm s =
+ radioIcon cls (SetTempl g) "Template \{nm}" (s.mode == SetTempl g)
+
+pse : Mode -> Bool
+pse (PTable _) = True
+pse (SetAtom i) = all (i.elem /=) (the (List Elem) [C,O,N,F,P,S,Cl,Br])
+pse _ = False
+
+leftBar : (pre : String) -> DrawState -> Node DrawEvent
+leftBar pre s =
+ div
+ [ Id $ leftBarID pre, class "cyby_draw_toolbar_left" ]
+ [ radioIcon "setC" (SetElem C) "Carbon" (setting C s)
+ , radioIcon "setO" (SetElem O) "Oxygen" (setting O s)
+ , radioIcon "setN" (SetElem N) "Nitrogen" (setting N s)
+ , radioIcon "setF" (SetElem F) "Fluorine" (setting F s)
+ , radioIcon "setP" (SetElem P) "Phosphorus" (setting P s)
+ , radioIcon "setS" (SetElem S) "Sulfur" (setting S s)
+ , radioIcon "setCl" (SetElem Cl) "Chlorine" (setting Cl s)
+ , radioIcon "setBr" (SetElem Br) "Bromine" (setting Br s)
+ , radioIcon "pse" StartPSE "PSE" (pse s.mode)
+ ]
+
+detail : String -> Node e -> Node e
+detail title n =
+ div
+ [class "cyby_draw_detail"]
+ [label [ class "cyby_draw_label" ] [ Text title ], n]
+
+
+rightBar : (pre : String) -> DrawState -> Node DrawEvent
+rightBar pre s =
+ case selectedNodes s.imol False of
+ [n] =>
+ let atm := atom $ lab s.imol n
+ tpe := atm.type.name
+ in div
+ [ Id $ rightBarID pre, class "cyby_draw_toolbar_right" ]
+ [ detail "Element" $ elems atm
+ , detail "Isotope" $ massNrs atm
+ , detail "Charge" $ charges atm
+ , detail "Type" $ div [ class "cyby_draw_atomtype"] [Text tpe]
+ ]
+ _ => div [ Id $ rightBarID pre, class "cyby_draw_toolbar_right" ] []
+
+bottomBar : (pre : String) -> DrawState -> Node DrawEvent
+bottomBar pre s =
+ div
+ [ Id $ bottomBarID pre, class "cyby_draw_toolbar_bottom_inner" ]
+ [ template "benzene" phenyl "Benzene" s
+ , template "cyclohexane" (ring 6) "Cyclohexane" s
+ , template "cyclopentane" (ring 5) "Cyclopentane" s
+ , template "cyclopropane" (ring 3) "Cyclopropane" s
+ , template "cyclobutane" (ring 4) "Cyclobutane" s
+ , template "cycloheptane" (ring 7) "Cycloheptane" s
+ , template "cyclooctane" (ring 8) "Cyclooctane" s
+ ]
+
+px : Double -> String
+px v = show (cast {to = Bits32} v) ++ "px"
+
+export
+sketcher : DrawSettings => (pre : String) -> DrawState -> Node DrawEvent
+sketcher pre s =
+ div
+ [ class "cyby_draw_main_content"
+ , Id $ sketcherDiv pre
+ ]
+ [ div
+ [ class "cyby_draw_sketcher_div"
+ , Id $ sketcherDivInner pre
+ ]
+ [ topBar pre s
+ , leftBar pre s
+ , rightBar pre s
+ , div
+ [ class "cyby_draw_molecule_canvas"
+ , Id $ moleculeCanvas pre
+ , Event $ MouseMove move
+ , Event $ MouseDown down
+ , Event $ MouseUp up
+ , Event_ True False $ Wheel wheel
+ , Event_ True False $ KeyDown (Just . KeyDown . key)
+ , Event_ True False $ KeyUp (Just . KeyUp . key)
+ , onMouseEnter Focus
+ , onMouseLeave Blur
+ , onDblClick Expand
+ , onResize (\r => EndResizeHW r.height r.width)
+ , Str "tabindex" "1"
+ , style "width:\{px s.dims.swidth};height:\{px s.dims.sheight}"
+ ]
+ [Raw s.curSVG]
+ , div
+ [ class "cyby_draw_toolbar_bottom_outer" ]
+ [ bottomBar pre s, abbrs pre s ]
+ ]
+ , div [ Id $ infoList pre, class "cyby_draw_info_list" ] []
+ ]
+
+--------------------------------------------------------------------------------
+-- Controller
+--------------------------------------------------------------------------------
+
+molCanvasCls : String
+molCanvasCls = "cyby_draw_molecule_canvas"
+
+parameters {auto ds : DrawSettings}
+ (pre : String)
+
+ canvasCls : List String -> Cmd e
+ canvasCls = attr (moleculeCanvas pre) . classes . (molCanvasCls ::)
+
+ rotating : Cmd e
+ rotating = canvasCls ["rotating"]
+
+ dragging : Cmd e
+ dragging = canvasCls ["dragging"]
+
+ normal : Cmd e
+ normal = canvasCls []
+
+ selectCursor : DrawState -> Cmd DrawEvent
+ selectCursor s =
+ case s.mode of
+ Dragging _ => dragging
+ Rotating _ => rotating
+ RotTempl _ _ => rotating
+ Translating _ => dragging
+ _ => applyWhenSel s dragging rotating normal
+
+ adjAbbrCls : DrawState -> Cmd DrawEvent
+ adjAbbrCls s = attr (abbrID pre) . classes $ abbrCls s
+
+ focusCurrentApp : Cmd DrawEvent
+ focusCurrentApp = focus (moleculeCanvas pre)
+
+ displayST : DrawState -> Cmd DrawEvent
+ displayST s =
+ cmdIf (s.curSVG /= s.prevSVG) $
+ child (moleculeCanvas pre) (Raw s.curSVG)
+
+ adjustBars : DrawState -> Cmd DrawEvent
+ adjustBars s =
+ replace (topBarID pre) (topBar pre s) <+>
+ replace (bottomBarID pre) (bottomBar pre s) <+>
+ replace (leftBarID pre) (leftBar pre s) <+>
+ adjAbbrCls s
+
+ adjustRightBar : DrawState -> Cmd DrawEvent
+ adjustRightBar s =
+ replace (rightBarID pre) (rightBar pre s) <+>
+ adjAbbrCls s
+
+ onResize : (Double -> Double -> DrawEvent) -> Cmd DrawEvent
+ onResize f =
+ C $ \h => do
+ r <- boundingRect (moleculeCanvas pre)
+ h $ f r.height r.width
+
+ dispKeyDown : String -> DrawState -> Cmd DrawEvent
+ dispKeyDown "Escape" s = replace (sketcherDiv pre) (sketcher pre s)
+ dispKeyDown "c" s =
+ cmdIf (s.modifier == Ctrl) $
+ let g := selectedSubgraph True s.mol
+ in cmdIf (g.order > 0) $
+ cmd_ (molToClipboard g) <+> pure (Msg Copied)
+ dispKeyDown "x" s =
+ cmdIf (s.modifier == Ctrl) $
+ let g := selectedSubgraph False s.mol
+ in cmdIf (g.order > 0) $
+ cmd_ (molToClipboard g) <+>
+ pure (KeyDown "Delete") <+>
+ pure (Msg Copied)
+ dispKeyDown "v" s = cmdIf (s.modifier == Ctrl) fromClipboard
+ dispKeyDown "Ctrl" s = selectCursor s
+ dispKeyDown _ s = neutral
+
+ displayEv : DrawEvent -> DrawState -> Cmd DrawEvent
+ displayEv Focus s = focusCurrentApp
+ displayEv Blur s = blur (moleculeCanvas pre)
+ displayEv (KeyDown k) s = dispKeyDown k s
+ displayEv (KeyUp _) s = adjustRightBar s
+ displayEv (SetElem _) s = adjustBars s
+ displayEv (SelAbbr _) s = adjustBars s
+ displayEv EnableAbbr s = adjustBars s
+ displayEv (SetBond _) s = adjustBars s
+ displayEv (SetTempl _) s = adjustBars s
+ displayEv SelectMode s = adjustBars s
+ displayEv EraseMode s = adjustBars s
+ displayEv (ChgElem _) s = adjustRightBar s
+ displayEv (Move _ _) s = selectCursor s
+ displayEv MiddleDown s = selectCursor s
+ displayEv MiddleUp s = selectCursor s
+ displayEv LeftUp s = adjustBars s <+> adjustRightBar s
+ displayEv Undo s = adjustBars s
+ displayEv Redo s = adjustBars s
+ displayEv (ZoomIn _) s = adjustBars s
+ displayEv (ZoomOut _) s = adjustBars s
+ displayEv Clear s = adjustBars s
+ displayEv _ s = neutral
+
+ export
+ displaySketcher : DrawEvent -> DrawState -> Cmd DrawEvent
+ displaySketcher e s = displayEv e s <+> displayST s
+
+||| Renders a molecule at the given canvas.
+|||
+||| The molecule will be scaled and centered to fit the canvas and
+||| the given nodes will be highlighted.
+export
+displayMol :
+ {auto ds : DrawSettings}
+ -> SceneDims
+ -> MolGraphAT
+ -> Maybe (List Nat)
+ -> Node e
+displayMol sd g m =
+ let cdg := initGraph g
+ G o mg := maybe cdg (\ns => highlight ns cdg) m
+ in Raw . curSVG $ initMol sd Fill $ G o mg
diff --git a/src/CyBy/Draw/Draw.idr b/src/CyBy/Draw/Draw.idr
new file mode 100644
index 0000000..4a641e4
--- /dev/null
+++ b/src/CyBy/Draw/Draw.idr
@@ -0,0 +1,331 @@
+||| Drawing Utilities
+module CyBy.Draw.Draw
+
+import CyBy.Draw.Internal.Abbreviations
+import CyBy.Draw.Internal.Atom
+import CyBy.Draw.Internal.CoreDims
+import CyBy.Draw.Internal.DoubleBond
+import CyBy.Draw.Internal.Color
+import CyBy.Draw.Internal.Graph
+import CyBy.Draw.Internal.Label
+import CyBy.Draw.Internal.Role
+import CyBy.Draw.Internal.Settings
+import CyBy.Draw.Internal.Wedge
+import Geom
+import Text.Molfile
+import Text.SVG
+import Text.SVG.Attribute as A
+
+%default total
+
+--------------------------------------------------------------------------------
+-- Basic Shapes
+--------------------------------------------------------------------------------
+
+export
+fillCircle : SVGColor -> Point Id -> Double -> SVGNode
+fillCircle c (P x y) rv = circle [cx x.u, cy y.u, r rv.u, fill c, stroke none]
+
+export
+roundedRect :
+ {auto cd : CoreDims}
+ -> (p1,p2 : Point Id)
+ -> List (SVGAttribute "rect")
+ -> SVGNode
+roundedRect (P a b) (P d e) as =
+ rect $
+ x (min a d).u
+ :: y (min b e).u
+ :: rx cd.radiusAtom.u
+ :: ry cd.radiusAtom.u
+ :: width (abs $ a - d).u
+ :: height (abs $ b - e).u
+ :: as
+
+export
+fillRect : (cd : CoreDims) => SVGColor -> (p1,p2 : Point Id) -> SVGNode
+fillRect c x y = roundedRect x y [fill c, stroke c]
+
+export
+outlineRect : (cd : CoreDims) => SVGColor -> (p1,p2 : Point Id) -> SVGNode
+outlineRect c x y = roundedRect x y [fill none, stroke c]
+
+export
+outlineRectD : (cd : CoreDims) => SVGColor -> (p1,p2 : Point Id) -> SVGNode
+outlineRectD c x y =
+ roundedRect x y [fill none, stroke c, strokeDasharray [5,5]]
+
+export
+singleLine : SVGColor -> Point Id -> Point Id -> SVGNode
+singleLine c (P x1 y1) (P x2 y2) = path [d [M x1 y1, L x2 y2], stroke c]
+
+export
+text : (cd : CoreDims) => Text (Point Id) -> SVGNode
+text (T _ "" _ _) = Empty
+text l =
+ let P a b := l.pos
+ P x y := l.textPos
+ -- disable pointer-events, because we do not want text to be
+ -- selectable, nor do we want a different mouse pointer when
+ -- over text nodes.
+ as1 := [A.x x.u, A.y y.u, Style "pointer-events" "none"]
+ as2 := if l.fsize == cd.fontSize then as1 else (fontSize (cast l.fsize).px :: as1)
+ in text1 as2 l.text
+
+--------------------------------------------------------------------------------
+-- Collecting Shapes
+--------------------------------------------------------------------------------
+
+||| We group the different layers of the drawing - carbon skeleton, atom labels
+||| background highlights - in lists of nodes wrapped by a `` element
+||| listing the key properties of the group.
+|||
+||| Snoc lists are the natural choice for assembling these groups of
+||| nodes from head to tail.
+public export
+record Nodes where
+ constructor NS
+ ||| The skeleton of the molecule: All bonds collected in a single ``
+ ||| element except upward bonds, which are polygons rather than lines.
+ skeleton : SnocList PathCmd
+
+ ||| Background shapes mainly use for selected or otherwise highlighted
+ ||| atoms and bonds.
+ bgShapes : SnocList SVGNode
+
+ ||| Upward wedges
+ wedges : SnocList SVGNode
+
+ ||| All text labels (including charges, implici hydrogens,
+ ||| mass numbers, and abbreviations)
+ txtLbls : SnocList SVGNode
+
+export
+init : Nodes
+init = NS [<] [<] [<] [<]
+
+public export
+0 TNodes : Type
+TNodes = Nodes -> Nodes
+
+pathAttrs : SVGColor -> (lw : Double) -> List (SVGAttribute "g")
+pathAttrs c lw =
+ [stroke c, strokeWidth lw.u, fill none, strokeLinecap Round]
+
+-- shapes have fill and stroke (to allow for rounded corners)
+shapeAttrs : SVGColor -> (lw : Double) -> List (SVGAttribute "g")
+shapeAttrs c w =
+ [stroke c, fill c, strokeWidth w.u, strokeLinecap Round, strokeLinejoin Round]
+
+fontAttrs : (ds : DrawSettings) => List (SVGAttribute "g")
+fontAttrs =
+ [ stroke none
+ , fill ds.textColor
+ , fontFamily ds.core.font
+ , fontSize (cast ds.core.fontSize).px
+ , textAnchor Middle
+ ]
+
+group : List (SVGAttribute "g") -> List SVGNode -> SVGNode
+group as [] = Empty
+group as ns = g as ns
+
+export
+toNodes : (ds : DrawSettings) => TNodes -> List SVGNode
+toNodes f =
+ let (NS fgp bgs fgs lbls) := f init
+ in [ group (shapeAttrs ds.selectBG ds.core.bondBGWidth) (bgs <>> [])
+ , group (pathAttrs ds.bondColor ds.core.bondWidth) [path [d (fgp <>> [])]]
+ , group (shapeAttrs ds.bondColor ds.core.bondWidth) (fgs <>> [])
+ , group (fontAttrs) (lbls <>> [])
+ ]
+
+--------------------------------------------------------------------------------
+-- Basic Shapes
+--------------------------------------------------------------------------------
+
+addToBG : SVGNode -> TNodes
+addToBG n = {bgShapes $= (:< n)}
+
+addLbl : SVGNode -> TNodes
+addLbl n = {txtLbls $= (:< n)}
+
+addCircle : SVGColor -> Point Id -> Double -> TNodes
+addCircle c p rv = addToBG (fillCircle c p rv)
+
+line : Point Id -> Point Id -> TNodes
+line (P x1 y1) (P x2 y2) = {skeleton $= (:< M x1 y1 :< L x2 y2)}
+
+lineBG : Maybe SVGColor -> Point Id -> Point Id -> TNodes
+lineBG Nothing _ _ ns = ns
+lineBG (Just c) x y ns = addToBG (singleLine c x y) ns
+
+wedgeDown : CoreDims => Point Id -> Point Id -> TNodes
+wedgeDown p1 p2 = {skeleton $= (<>< Wedge.wedgeDown p1 p2)}
+
+wedgeUp : CoreDims => Point Id -> Point Id -> TNodes
+wedgeUp p1 p2 = {wedges $= (:< Wedge.wedgeUp p1 p2 [])}
+
+wedgeBG : CoreDims => Maybe SVGColor -> Point Id -> Point Id -> TNodes
+wedgeBG Nothing _ _ ns = ns
+wedgeBG (Just c) p1 p2 ns =
+ addToBG (Wedge.wedgeUp p1 p2 [fill c, stroke c]) ns
+
+wave : CoreDims => Point Id -> Point Id -> TNodes
+wave p1 p2 = {skeleton $= (<>< Wedge.wave p1 p2)}
+
+waveBG : CoreDims => Maybe SVGColor -> Point Id -> Point Id -> TNodes
+waveBG Nothing _ _ ns = ns
+waveBG (Just c) p1 p2 ns =
+ addToBG (path [d (Wedge.wave p1 p2), stroke c, fill none]) ns
+
+atmLabels : CoreDims => SVGColor -> AtomLabels (Point Id) -> TNodes
+atmLabels c ls = addLbl (group [fill c] (text <$> labels ls))
+
+labelBG : SVGColor -> Text (Point Id) -> TNodes
+labelBG c l =
+ case radius l of
+ Nothing => id
+ Just r => addCircle c l.pos r
+
+abbrBG : CoreDims => SVGColor -> Text (Point Id) -> TNodes
+abbrBG c t ns =
+ let Just (p1,p2) := corners (bounds t) | Nothing => ns
+ in addToBG (fillRect c p1 p2) ns
+
+--------------------------------------------------------------------------------
+-- Colors
+--------------------------------------------------------------------------------
+
+-- color to use as the background for bonds and atoms
+background :
+ {0 a : Type}
+ -> {auto cst : Cast a Role}
+ -> {auto s : DrawSettings}
+ -> (dflt : Maybe SVGColor)
+ -> a
+ -> Maybe SVGColor
+background deflt v =
+ if is New v then Just s.newBG
+ else if is Origin v then Just s.originBG
+ else if is Hover v then Just s.hoverBG
+ else if is Selected v then Just s.selectBG
+ else if is Highlight v then Just s.highlightBG
+ else deflt
+
+--------------------------------------------------------------------------------
+-- Drawing Molecules
+--------------------------------------------------------------------------------
+
+parameters {auto s : DrawSettings}
+ {k : _}
+ (g : CDIGraph k)
+
+ abbrText : AbbrPos -> String -> String
+ abbrText AE t = t
+ abbrText AW t = reverseLabel t s.abbreviations
+
+ export
+ label : Fin k -> Label
+ label x =
+ case visible g x of
+ False => Hidden
+ True => case labelVisible s.showC g x of
+ False => NoLabel (pointAt g x)
+ True => case group (lab g x) of
+ Just (G _ a) =>
+ let ap := abbrPos g x
+ p := pointAt g x
+ in Abbreviation p $ abbrTextPos ap p (text False $ abbrText ap a)
+ Nothing =>
+ let atm := atom $ lab g x
+ sym := text False (symbol atm.elem.elem)
+ ch := text True (chargeLabel atm.charge)
+ mn := text True (massLabel atm.elem.mass)
+ hl := text False (hlabel atm.hydrogen)
+ hc := text True (hsubscript atm.hydrogen)
+ in Explicit $ setPositions (hpos g x) (pointId atm) (AL sym ch mn hl hc)
+
+ export
+ labels : Labels k
+ labels = generate k label
+
+ atomBG : Labels k -> Fin k -> TNodes
+ atomBG ls x ns =
+ let atm := lab g x
+ dflt := if isInvalid atm.atom.type then Just s.errorBG else Nothing
+ in case background dflt atm of
+ Nothing => ns
+ Just c => case at ls x of
+ Abbreviation _ abbr => abbrBG c abbr ns
+ Explicit l => foldl (flip $ labelBG c) ns (labels l)
+ NoLabel p => addCircle c p s.core.radiusAtom ns
+ Hidden => ns
+
+ drawAtom : Labels k -> Nodes -> Fin k -> Nodes
+ drawAtom ls ns x =
+ let ns2 := atomBG ls x ns
+ in case at ls x of
+ Abbreviation _ abbr => addLbl (text abbr) ns2
+ Explicit l => atmLabels (s.elemColor (cast $ lab g x)) l ns2
+ NoLabel p => ns2
+ Hidden => ns2
+
+ snglBond : Maybe SVGColor -> Point Id -> Point Id -> BondStereo -> TNodes
+ snglBond c x y Up ns = wedgeUp x y $ wedgeBG c x y ns
+ snglBond c x y UpOrDown ns = wave x y $ waveBG c x y ns
+ snglBond c x y Down ns = wedgeDown x y $ wedgeBG c x y ns
+ snglBond c x y _ ns = line x y $ lineBG c x y ns
+
+ dblBond : Maybe SVGColor -> Fin k -> Fin k -> Point Id -> Point Id -> TNodes
+ dblBond c x y px py ns =
+ let [a,b,d,e] := dblBond g x y (pointAt g x) (pointAt g y) px py
+ in line a b . line d e . lineBG c a b $ lineBG c d e ns
+
+ trplBond : Maybe SVGColor -> Point Id -> Point Id -> TNodes
+ trplBond c x y ns =
+ let r := 0.8 * s.core.radiusAtom
+ (a,b) := parallelLine r True x y
+ (d,e) := parallelLine r False x y
+ in line x y . line a b . line d e .
+ lineBG c x y . lineBG c a b $ lineBG c d e ns
+
+ addBond :
+ MolBond
+ -> Maybe SVGColor
+ -> (x,y : Fin k)
+ -> (px,py : Point Id)
+ -> TNodes
+ addBond (MkBond True Single st) c x y px py = snglBond c px py st
+ addBond (MkBond False Single st) c x y px py = snglBond c py px st
+ addBond (MkBond _ Dbl _ ) c x y px py = dblBond c x y px py
+ addBond (MkBond _ Triple _ ) c x y px py = trplBond c px py
+
+ drawBond : Labels k -> Nodes -> Edge k CDBond -> Nodes
+ drawBond ls ns (E x y b) =
+ let c := background Nothing b
+ px := pointAt g x
+ py := pointAt g y
+ lx := at ls x
+ ly := at ls y
+ Just (qx,qy) := endpoints px py lx ly | Nothing => ns
+ in addBond b.molBond c x y qx qy ns
+
+export
+drawMolecule : DrawSettings => CDGraph -> List SVGNode
+drawMolecule (G o g) = toNodes (scene $ labels g)
+ where
+ scene : Labels o -> TNodes
+ scene ls ns =
+ foldl (drawAtom g ls) (foldl (drawBond g ls) ns (edges g)) (nodes g)
+
+--------------------------------------------------------------------------------
+-- Drawing Utilities
+--------------------------------------------------------------------------------
+
+export
+rotateTemplScene : DrawSettings => Point Mol -> Point Mol -> List SVGNode
+rotateTemplScene @{ds} o m =
+ [ fillCircle ds.hoverBG (convert o) ds.core.radiusAtom
+ , singleLine ds.hoverBG (convert o) (convert m)
+ ]
diff --git a/src/CyBy/Draw/Event.idr b/src/CyBy/Draw/Event.idr
new file mode 100644
index 0000000..45f832c
--- /dev/null
+++ b/src/CyBy/Draw/Event.idr
@@ -0,0 +1,78 @@
+module CyBy.Draw.Event
+
+import CyBy.Draw.Internal.Abbreviations
+import CyBy.Draw.Internal.Atom
+import CyBy.Draw.Internal.Graph
+import Derive.Prelude
+import Text.Molfile
+import Web.MVC
+import Web.MVC.Canvas
+
+%default total
+%language ElabReflection
+
+--------------------------------------------------------------------------------
+-- Event
+--------------------------------------------------------------------------------
+
+||| Modifier key such as "Shift" or "Ctrl" currently being pressed.
+public export
+data Modifier = NoMod | Ctrl | Shift
+
+%runElab derive "Modifier" [Show, Eq]
+
+||| Resets the pressed modifier key if it matches the keyboard key being
+||| lifted.
+export
+reset : (mod, current : Modifier) -> Modifier
+reset m c = if m == c then NoMod else c
+
+||| A data type for logging messages.
+|||
+||| Typically, these will not be handled by cyby-draw directly but
+||| by applications embedding our drawing canvas into their own
+||| UI.
+public export
+data DrawMsg : Type where
+ ||| Data was copied to clipboard
+ Copied : DrawMsg
+
+ ||| Invalid data was read from clipboard
+ ReadErr : String -> DrawMsg
+
+%runElab derive "DrawMsg" [Show, Eq]
+
+public export
+data DrawEvent : Type where
+ ZoomIn : (atPos : Bool) -> DrawEvent
+ ZoomOut : (atPos : Bool) -> DrawEvent
+ Undo : DrawEvent
+ Redo : DrawEvent
+ SetElem : Elem -> DrawEvent
+ ChgElem : Elem -> DrawEvent
+ ChgCharge : Charge -> DrawEvent
+ ChgMass : Maybe MassNr -> DrawEvent
+ SelAbbr : Abbreviation -> DrawEvent
+ EnableAbbr : DrawEvent
+ SetBond : MolBond -> DrawEvent
+ Move : (x,y : Double) -> DrawEvent
+ LeftDown : DrawEvent
+ LeftUp : DrawEvent
+ MiddleDown : DrawEvent
+ MiddleUp : DrawEvent
+ SetTempl : CDGraph -> DrawEvent
+ SelectMode : DrawEvent
+ KeyDown : String -> DrawEvent
+ KeyUp : String -> DrawEvent
+ EraseMode : DrawEvent
+ Focus : DrawEvent
+ Blur : DrawEvent
+ Clear : DrawEvent
+ Expand : DrawEvent
+ Center : DrawEvent
+ Msg : DrawMsg -> DrawEvent
+ EndResize : DrawEvent
+ EndResizeHW : (h,w : Double) -> DrawEvent
+ StartPSE : DrawEvent
+
+%runElab derive "DrawEvent" [Show, Eq]
diff --git a/src/CyBy/Draw/Internal/Abbreviations.idr b/src/CyBy/Draw/Internal/Abbreviations.idr
new file mode 100644
index 0000000..60c88e4
--- /dev/null
+++ b/src/CyBy/Draw/Internal/Abbreviations.idr
@@ -0,0 +1,165 @@
+module CyBy.Draw.Internal.Abbreviations
+
+import CyBy.Draw.Internal.Atom
+import CyBy.Draw.Internal.Graph
+import Derive.Prelude
+import Text.Molfile
+
+%default total
+%language ElabReflection
+
+public export
+record Abbreviation where
+ constructor A
+ label : String
+ ||| Label to use when printing the abbreviation from right to left
+ revlbl : String
+ graph : CDGraph
+
+%runElab derive "Abbreviation" [Show,Eq]
+
+abbr : String -> String -> String -> Abbreviation
+abbr x y = A x y . readMolfile
+
+export
+reverseLabel : String -> List Abbreviation -> String
+reverseLabel s [] = s
+reverseLabel s (A l r _ :: xs) = if s == l then r else reverseLabel s xs
+
+ph, cy : String
+ac, oAc, bn, bz : String
+
+export
+phenyl : CDGraph
+phenyl = readMolfile ph
+
+export
+abbreviations : List Abbreviation
+abbreviations =
+ [ abbr "Ac" "Ac" ac
+ , abbr "Bn" "Bn" bn
+ , abbr "Bz" "Bz" bz
+ , abbr "Cy" "Cy" cy
+ , abbr "OAc" "AcO" oAc
+ , abbr "Ph" "Ph" ph
+ ]
+
+ac =
+ """
+
+ created by cyby-draw 1.0
+
+ 3 2 0 V2000
+ -2.3125 2.9375 0.0000 C
+ -2.3125 4.1875 0.0000 O
+ -3.3950 2.3124 0.0000 C
+ 1 2 2 0
+ 1 3 1 0
+ M END
+ """
+
+oAc =
+ """
+
+ created by cyby-draw 1.0
+
+ 4 3 0 V2000
+ -2.1875 1.6875 0.0000 O
+ -1.1049 2.3125 0.0000 C
+ -0.0223 1.6875 0.0000 C
+ -1.1049 3.5625 0.0000 O
+ 1 2 1 0
+ 2 3 1 0
+ 2 4 2 0
+ M END
+ """
+
+ph =
+ """
+
+ created by cyby-draw 1.0
+
+ 6 6 0 V2000
+ -0.3125 1.5625 0.0000 C
+ -1.3949 0.9375 0.0000 C
+ -1.3949 -0.3125 0.0000 C
+ -0.3125 -0.9375 0.0000 C
+ 0.7699 -0.3125 0.0000 C
+ 0.7699 0.9375 0.0000 C
+ 1 2 1 0
+ 1 6 2 0
+ 2 3 2 0
+ 3 4 1 0
+ 4 5 2 0
+ 5 6 1 0
+ M END
+ """
+
+cy =
+ """
+
+ created by cyby-draw 1.0
+
+ 6 6 0 V2000
+ -0.3125 1.5625 0.0000 C
+ -1.3949 0.9375 0.0000 C
+ -1.3949 -0.3125 0.0000 C
+ -0.3125 -0.9375 0.0000 C
+ 0.7699 -0.3125 0.0000 C
+ 0.7699 0.9375 0.0000 C
+ 1 2 1 0
+ 1 6 1 0
+ 2 3 1 0
+ 3 4 1 0
+ 4 5 1 0
+ 5 6 1 0
+ M END
+ """
+
+bn =
+ """
+
+ created by cyby-draw 1.0
+
+ 7 7 0 V2000
+ -5.8125 2.0625 0.0000 C
+ -3.6476 4.5625 0.0000 C
+ -4.7299 3.9375 0.0000 C
+ -4.7299 2.6875 0.0000 C
+ -3.6476 2.0625 0.0000 C
+ -2.5650 2.6875 0.0000 C
+ -2.5650 3.9375 0.0000 C
+ 1 4 1 0
+ 2 3 1 0
+ 2 7 2 0
+ 3 4 2 0
+ 4 5 1 0
+ 5 6 2 0
+ 6 7 1 0
+ M END
+ """
+
+bz =
+ """
+
+ created by cyby-draw 1.0
+
+ 8 8 0 V2000
+ -5.8125 2.0625 0.0000 C
+ -3.6476 4.5625 0.0000 C
+ -4.7299 3.9375 0.0000 C
+ -4.7299 2.6875 0.0000 C
+ -3.6476 2.0625 0.0000 C
+ -2.5650 2.6875 0.0000 C
+ -2.5650 3.9375 0.0000 C
+ -5.8125 0.8125 0.0000 O
+ 1 4 1 0
+ 1 8 2 0
+ 2 3 1 0
+ 2 7 2 0
+ 3 4 2 0
+ 4 5 1 0
+ 5 6 2 0
+ 6 7 1 0
+ M END
+ """
diff --git a/src/CyBy/Draw/Internal/Atom.idr b/src/CyBy/Draw/Internal/Atom.idr
new file mode 100644
index 0000000..c170a0e
--- /dev/null
+++ b/src/CyBy/Draw/Internal/Atom.idr
@@ -0,0 +1,80 @@
+module CyBy.Draw.Internal.Atom
+
+import CyBy.Draw.Internal.Role
+import Derive.Prelude
+import Geom
+import Text.Molfile
+
+%language ElabReflection
+%default total
+
+||| Atom type used in the application state of cyby-draw.
+|||
+||| This is a mol-file atom with perceived atom type paired with a role
+||| used for drawing.
+public export
+record CDAtom where
+ constructor CA
+ role : Role
+ atom : MolAtomAT
+
+%runElab derive "CDAtom" [Show,Eq]
+
+export %inline
+group : CDAtom -> Maybe AtomGroup
+group = label . atom
+
+export %inline
+inAnyGroup : CDAtom -> Bool
+inAnyGroup = isJust . group
+
+||| Sets the given `AtomGroup` (abbreviation) at an atom
+export
+setGroup : AtomGroup -> CDAtom -> CDAtom
+setGroup g (CA r a) = CA r $ {label := Just g} a
+
+||| Unsets the abbreviation label of an atom if it belongs to
+||| the given group.
+export
+clearGroup : (group : Nat) -> CDAtom -> CDAtom
+clearGroup g (CA r a) = CA r $ {label $= (>>= clear)} a
+ where
+ clear : AtomGroup -> Maybe AtomGroup
+ clear (G x l) = if x == g then Nothing else (Just $ G x l)
+
+||| True, if the given atom is part of the abbreviation with the given ID.
+export %inline
+inGroup : Nat -> CDAtom -> Bool
+inGroup n (CA _ a) =
+ case a.label of
+ Nothing => False
+ Just (G m _) => n == m
+
+--------------------------------------------------------------------------------
+-- Implementations
+--------------------------------------------------------------------------------
+
+export %inline
+Cast CDAtom Role where cast = role
+
+export %inline
+Cast (Adj k b CDAtom) Role where cast = cast . label
+
+export %inline
+Cast (Context k b CDAtom) Role where cast = cast . label
+
+export %inline
+ModRole CDAtom where modRole f = {role $= f}
+
+public export
+GetPoint CDAtom where
+ gtrans = Mol
+ point = point . position . atom
+
+export %inline
+Cast CDAtom Elem where cast = elem . elem . atom
+
+public export
+ModPoint CDAtom where
+ mtrans = Mol
+ modPoint f (CA r v) = CA r $ {position $= modPoint f} v
diff --git a/src/CyBy/Draw/Internal/Color.idr b/src/CyBy/Draw/Internal/Color.idr
new file mode 100644
index 0000000..eee9bb8
--- /dev/null
+++ b/src/CyBy/Draw/Internal/Color.idr
@@ -0,0 +1,307 @@
+module CyBy.Draw.Internal.Color
+
+import Text.Molfile
+import Text.SVG.Types
+
+%default total
+
+export
+jmolColor : Elem -> SVGColor
+jmolColor H = RGB 0xFF 0xFF 0xFF
+jmolColor He = RGB 0xD9 0xFF 0xFF
+jmolColor Li = RGB 0xCC 0x80 0xFF
+jmolColor Be = RGB 0xC2 0xFF 0x00
+jmolColor B = RGB 0xFF 0xB5 0xB5
+jmolColor C = RGB 0x90 0x90 0x90
+jmolColor N = RGB 0x30 0x50 0xF8
+jmolColor O = RGB 0xFF 0x0D 0x0D
+jmolColor F = RGB 0x90 0xE0 0x50
+jmolColor Ne = RGB 0xB3 0xE3 0xF5
+jmolColor Na = RGB 0xAB 0x5C 0xF2
+jmolColor Mg = RGB 0x8A 0xFF 0x00
+jmolColor Al = RGB 0xBF 0xA6 0xA6
+jmolColor Si = RGB 0xF0 0xC8 0xA0
+jmolColor P = RGB 0xFF 0x80 0x00
+jmolColor S = RGB 0xFF 0xFF 0x30
+jmolColor Cl = RGB 0x1F 0xF0 0x1F
+jmolColor Ar = RGB 0x80 0xD1 0xE3
+jmolColor K = RGB 0x8F 0x40 0xD4
+jmolColor Ca = RGB 0x3D 0xFF 0x00
+jmolColor Sc = RGB 0xE6 0xE6 0xE6
+jmolColor Ti = RGB 0xBF 0xC2 0xC7
+jmolColor V = RGB 0xA6 0xA6 0xAB
+jmolColor Cr = RGB 0x8A 0x99 0xC7
+jmolColor Mn = RGB 0x9C 0x7A 0xC7
+jmolColor Fe = RGB 0xE0 0x66 0x33
+jmolColor Co = RGB 0xF0 0x90 0xA0
+jmolColor Ni = RGB 0x50 0xD0 0x50
+jmolColor Cu = RGB 0xC8 0x80 0x33
+jmolColor Zn = RGB 0x7D 0x80 0xB0
+jmolColor Ga = RGB 0xC2 0x8F 0x8F
+jmolColor Ge = RGB 0x66 0x8F 0x8F
+jmolColor As = RGB 0xBD 0x80 0xE3
+jmolColor Se = RGB 0xFF 0xA1 0x00
+jmolColor Br = RGB 0xA6 0x29 0x29
+jmolColor Kr = RGB 0x5C 0xB8 0xD1
+jmolColor Rb = RGB 0x70 0x2E 0xB0
+jmolColor Sr = RGB 0x00 0xFF 0x00
+jmolColor Y = RGB 0x94 0xFF 0xFF
+jmolColor Zr = RGB 0x94 0xE0 0xE0
+jmolColor Nb = RGB 0x73 0xC2 0xC9
+jmolColor Mo = RGB 0x54 0xB5 0xB5
+jmolColor Tc = RGB 0x3B 0x9E 0x9E
+jmolColor Ru = RGB 0x24 0x8F 0x8F
+jmolColor Rh = RGB 0x0A 0x7D 0x8C
+jmolColor Pd = RGB 0x00 0x69 0x85
+jmolColor Ag = RGB 0xC0 0xC0 0xC0
+jmolColor Cd = RGB 0xFF 0xD9 0x8F
+jmolColor In = RGB 0xA6 0x75 0x73
+jmolColor Sn = RGB 0x66 0x80 0x80
+jmolColor Sb = RGB 0x9E 0x63 0xB5
+jmolColor Te = RGB 0xD4 0x7A 0x00
+jmolColor I = RGB 0x94 0x00 0x94
+jmolColor Xe = RGB 0x42 0x9E 0xB0
+jmolColor Cs = RGB 0x57 0x17 0x8F
+jmolColor Ba = RGB 0x00 0xC9 0x00
+jmolColor La = RGB 0x70 0xD4 0xFF
+jmolColor Ce = RGB 0xFF 0xFF 0xC7
+jmolColor Pr = RGB 0xD9 0xFF 0xC7
+jmolColor Nd = RGB 0xC7 0xFF 0xC7
+jmolColor Pm = RGB 0xA3 0xFF 0xC7
+jmolColor Sm = RGB 0x8F 0xFF 0xC7
+jmolColor Eu = RGB 0x61 0xFF 0xC7
+jmolColor Gd = RGB 0x45 0xFF 0xC7
+jmolColor Tb = RGB 0x30 0xFF 0xC7
+jmolColor Dy = RGB 0x1F 0xFF 0xC7
+jmolColor Ho = RGB 0x00 0xFF 0x9C
+jmolColor Er = RGB 0x00 0xE6 0x75
+jmolColor Tm = RGB 0x00 0xD4 0x52
+jmolColor Yb = RGB 0x00 0xBF 0x38
+jmolColor Lu = RGB 0x00 0xAB 0x24
+jmolColor Hf = RGB 0x4D 0xC2 0xFF
+jmolColor Ta = RGB 0x4D 0xA6 0xFF
+jmolColor W = RGB 0x21 0x94 0xD6
+jmolColor Re = RGB 0x26 0x7D 0xAB
+jmolColor Os = RGB 0x26 0x66 0x96
+jmolColor Ir = RGB 0x17 0x54 0x87
+jmolColor Pt = RGB 0xD0 0xD0 0xE0
+jmolColor Au = RGB 0xFF 0xD1 0x23
+jmolColor Hg = RGB 0xB8 0xB8 0xD0
+jmolColor Tl = RGB 0xA6 0x54 0x4D
+jmolColor Pb = RGB 0x57 0x59 0x61
+jmolColor Bi = RGB 0x9E 0x4F 0xB5
+jmolColor Po = RGB 0xAB 0x5C 0x00
+jmolColor At = RGB 0x75 0x4F 0x45
+jmolColor Rn = RGB 0x42 0x82 0x96
+jmolColor Fr = RGB 0x42 0x00 0x66
+jmolColor Ra = RGB 0x00 0x7D 0x00
+jmolColor Ac = RGB 0x70 0xAB 0xFA
+jmolColor Th = RGB 0x00 0xBA 0xFF
+jmolColor Pa = RGB 0x00 0xA1 0xFF
+jmolColor U = RGB 0x00 0x8F 0xFF
+jmolColor Np = RGB 0x00 0x80 0xFF
+jmolColor Pu = RGB 0x00 0x6B 0xFF
+jmolColor Am = RGB 0x54 0x5C 0xF2
+jmolColor Cm = RGB 0x78 0x5C 0xE3
+jmolColor Bk = RGB 0x8A 0x4F 0xE3
+jmolColor Cf = RGB 0xA1 0x36 0xD4
+jmolColor Es = RGB 0xB3 0x1F 0xD4
+jmolColor Fm = RGB 0xB3 0x1F 0xBA
+jmolColor Md = RGB 0xB3 0x0D 0xA6
+jmolColor No = RGB 0xBD 0x0D 0x87
+jmolColor Lr = RGB 0xC7 0x00 0x66
+jmolColor Rf = RGB 0xCC 0x00 0x59
+jmolColor Db = RGB 0xD1 0x00 0x4F
+jmolColor Sg = RGB 0xD9 0x00 0x45
+jmolColor Bh = RGB 0xE0 0x00 0x38
+jmolColor Hs = RGB 0xE6 0x00 0x2E
+jmolColor Mt = RGB 0xEB 0x00 0x26
+jmolColor Ds = RGB 0x00 0x00 0x00
+jmolColor Rg = RGB 0x00 0x00 0x00
+jmolColor Cn = RGB 0x00 0x00 0x00
+jmolColor Nh = RGB 0x00 0x00 0x00
+jmolColor Fl = RGB 0x00 0x00 0x00
+jmolColor Mc = RGB 0x00 0x00 0x00
+jmolColor Lv = RGB 0x00 0x00 0x00
+jmolColor Ts = RGB 0x00 0x00 0x00
+jmolColor Og = RGB 0x00 0x00 0x00
+
+export
+pymolColor : Elem -> SVGColor
+pymolColor H = RGB 0xE6 0xE6 0xE6
+pymolColor C = RGB 0x33 0xFF 0x33
+pymolColor N = RGB 0x33 0x33 0xFF
+pymolColor O = RGB 0xFF 0x4D 0x4D
+pymolColor F = RGB 0xB3 0xFF 0xFF
+pymolColor S = RGB 0xE6 0xC6 0x40
+pymolColor e = jmolColor e
+
+export
+cybyColor : Elem -> SVGColor
+cybyColor H = silver
+cybyColor C = dimgray
+cybyColor F = limegreen
+cybyColor S = RGB 0xE6 0xC6 0x40
+cybyColor e = jmolColor e
+
+-- Colors from CPK, ugly as they come
+-- Adpated H
+export
+cpkColor : Elem -> SVGColor
+cpkColor H = silver -- cdk: white
+cpkColor He = RGB 0xFF 0xC0 0xCB
+cpkColor Li = RGB 0xB2 0x22 0x22
+cpkColor B = RGB 0x00 0xFF 0x00
+cpkColor C = RGB 0xC8 0xC8 0xC8
+cpkColor N = RGB 0x8F 0x8F 0xFF
+cpkColor O = RGB 0xF0 0x00 0x00
+cpkColor F = RGB 0xDA 0xA5 0x20
+cpkColor Na = RGB 0x00 0x00 0xFF
+cpkColor Mg = RGB 0x22 0x8B 0x22
+cpkColor Al = RGB 0x80 0x80 0x90
+cpkColor Si = RGB 0xDA 0xA5 0x20
+cpkColor P = RGB 0xFF 0xA5 0x00
+cpkColor S = RGB 0xFF 0xC8 0x32
+cpkColor Cl = RGB 0x00 0xFF 0x00
+cpkColor Ca = RGB 0x80 0x80 0x90
+cpkColor Ti = RGB 0x80 0x80 0x90
+cpkColor Cr = RGB 0x80 0x80 0x90
+cpkColor Mn = RGB 0x80 0x80 0x90
+cpkColor Fe = RGB 0xFF 0xA5 0x00
+cpkColor Ni = RGB 0xA5 0x2A 0x2A
+cpkColor Cu = RGB 0xA5 0x2A 0x2A
+cpkColor Zn = RGB 0xA5 0x2A 0x2A
+cpkColor Br = RGB 0xA5 0x2A 0x2A
+cpkColor Ag = RGB 0x80 0x80 0x90
+cpkColor I = RGB 0xA0 0x20 0xF0
+cpkColor Ba = RGB 0xFF 0xA5 0x00
+cpkColor Au = RGB 0xDA 0xA5 0x20
+cpkColor _ = RGB 0xFF 0x14 0x93
+
+-- Colors as defined in CDKAtomColors
+-- Adapted Color for H and S
+export
+cdkColor : Elem -> SVGColor
+cdkColor H = silver -- cdk: white
+cdkColor C = black
+cdkColor N = blue
+cdkColor O = red
+cdkColor P = green
+cdkColor S = gold -- cdk: yellow
+cdkColor Cl = magenta
+cdkColor _ = RGB 0x48 0x48 0x48
+
+-- Coloring of important Elements
+-- The colors are:
+-- - H: lightgrey (RGB 0x90 0x90 0x90)
+-- - C: black
+-- - N: blue (RGB 0x0b 0x53 0x94)
+-- - O: red (RGB 0xcc 0x00 0x00)
+-- - P: brown (RGB 0xb4 0x5f 0x06)
+-- - S: yellow (RGB 0xe5 0xae 0x06)
+-- - Cl: green
+export
+basicColors : Elem -> SVGColor
+basicColors H = RGB 0x90 0x90 0x90
+basicColors C = black
+basicColors N = RGB 0x0b 0x53 0x94
+basicColors O = RGB 0xcc 0x00 0x00
+basicColors P = RGB 0xb4 0x5f 0x06
+basicColors S = RGB 0xe5 0xae 0x06
+basicColors Cl = green
+basicColors _ = RGB 0x48 0x48 0x48
+
+-- Colored PSE groups
+-- Addtionally to the specific coloring of important elements, the elements are
+-- colored according to the group they are in.
+-- The colors are:
+-- - alkali metals: dark pink (RGB 0xa6 0x4d 0x79)
+-- - alkaline earth metals: pink (RGB 0xc2 0x7b 0xa0)
+-- - transition metals: purple (RGB 0x9c 0x7a 0xc7)
+-- - metals: turquoise (RGB 0x42 0x9e 0xb0)
+-- - metalloids: blue (RGB 0x0b 0x53 0x94)
+-- - nonmetals: coloring of significnat elemets see basicColors
+-- - halogens: light green (RGB 0x0a 0x72 0x48)
+-- - noble gases: green (RGB 0x06 0x55 0x35)
+export
+groupColors : Elem -> SVGColor
+groupColors H = RGB 0x90 0x90 0x90
+groupColors C = black
+groupColors N = RGB 0x0b 0x53 0x94
+groupColors O = RGB 0xcc 0x00 0x00
+groupColors P = RGB 0xb4 0x5f 0x06
+groupColors S = gold
+groupColors Cl = RGB 0x3a 0x8e 0x6c
+groupColors He = RGB 0x06 0x55 0x35
+groupColors Ne = RGB 0x06 0x55 0x35
+groupColors Ar = RGB 0x06 0x55 0x35
+groupColors Kr = RGB 0x06 0x55 0x35
+groupColors Xe = RGB 0x06 0x55 0x35
+groupColors Rn = RGB 0x06 0x55 0x35
+groupColors Og = RGB 0x06 0x55 0x35
+groupColors F = RGB 0x0a 0x72 0x48
+groupColors Br = RGB 0x0a 0x72 0x48
+groupColors I = RGB 0x0a 0x72 0x48
+groupColors At = RGB 0x0a 0x72 0x48
+groupColors Ts = RGB 0x0a 0x72 0x48
+groupColors B = RGB 0x0b 0x53 0x94
+groupColors Si = RGB 0x0b 0x53 0x94
+groupColors Ge = RGB 0x0b 0x53 0x94
+groupColors As = RGB 0x0b 0x53 0x94
+groupColors Sb = RGB 0x0b 0x53 0x94
+groupColors Se = RGB 0x0b 0x53 0x94
+groupColors Te = RGB 0x0b 0x53 0x94
+groupColors Po = RGB 0x0b 0x53 0x94
+groupColors Al = RGB 0x42 0x9e 0xb0
+groupColors Ga = RGB 0x42 0x9e 0xb0
+groupColors In = RGB 0x42 0x9e 0xb0
+groupColors Tl = RGB 0x42 0x9e 0xb0
+groupColors Nh = RGB 0x42 0x9e 0xb0
+groupColors Sn = RGB 0x42 0x9e 0xb0
+groupColors Pb = RGB 0x42 0x9e 0xb0
+groupColors Fl = RGB 0x42 0x9e 0xb0
+groupColors Bi = RGB 0x42 0x9e 0xb0
+groupColors Mc = RGB 0x42 0x9e 0xb0
+groupColors Lv = RGB 0x42 0x9e 0xb0
+groupColors Be = RGB 0xc2 0x7b 0xa0
+groupColors Ca = RGB 0xc2 0x7b 0xa0
+groupColors Mg = RGB 0xc2 0x7b 0xa0
+groupColors Ca = RGB 0xc2 0x7b 0xa0
+groupColors Sr = RGB 0xc2 0x7b 0xa0
+groupColors Ba = RGB 0xc2 0x7b 0xa0
+groupColors Ra = RGB 0xc2 0x7b 0xa0
+groupColors Li = RGB 0xa6 0x4d 0x79
+groupColors Na = RGB 0xa6 0x4d 0x79
+groupColors K = RGB 0xa6 0x4d 0x79
+groupColors Rb = RGB 0xa6 0x4d 0x79
+groupColors Cs = RGB 0xa6 0x4d 0x79
+groupColors Fr = RGB 0xa6 0x4d 0x79
+groupColors Ce = RGB 0x72 0x70 0x74
+groupColors Pr = RGB 0x72 0x70 0x74
+groupColors Nd = RGB 0x72 0x70 0x74
+groupColors Pm = RGB 0x72 0x70 0x74
+groupColors Sm = RGB 0x72 0x70 0x74
+groupColors Eu = RGB 0x72 0x70 0x74
+groupColors Gd = RGB 0x72 0x70 0x74
+groupColors Tb = RGB 0x72 0x70 0x74
+groupColors Dy = RGB 0x72 0x70 0x74
+groupColors Ho = RGB 0x72 0x70 0x74
+groupColors Er = RGB 0x72 0x70 0x74
+groupColors Tm = RGB 0x72 0x70 0x74
+groupColors Yb = RGB 0x72 0x70 0x74
+groupColors Lu = RGB 0x72 0x70 0x74
+groupColors Th = RGB 0x48 0x48 0x48
+groupColors Pa = RGB 0x48 0x48 0x48
+groupColors U = RGB 0x48 0x48 0x48
+groupColors Np = RGB 0x48 0x48 0x48
+groupColors Pu = RGB 0x48 0x48 0x48
+groupColors Am = RGB 0x48 0x48 0x48
+groupColors Cm = RGB 0x48 0x48 0x48
+groupColors Bk = RGB 0x48 0x48 0x48
+groupColors Cf = RGB 0x48 0x48 0x48
+groupColors Es = RGB 0x48 0x48 0x48
+groupColors Fm = RGB 0x48 0x48 0x48
+groupColors Md = RGB 0x48 0x48 0x48
+groupColors No = RGB 0x48 0x48 0x48
+groupColors Lr = RGB 0x48 0x48 0x48
+groupColors _ = RGB 0x9c 0x7a 0xc7
diff --git a/src/CyBy/Draw/Internal/CoreDims.idr b/src/CyBy/Draw/Internal/CoreDims.idr
new file mode 100644
index 0000000..650a601
--- /dev/null
+++ b/src/CyBy/Draw/Internal/CoreDims.idr
@@ -0,0 +1,62 @@
+module CyBy.Draw.Internal.CoreDims
+
+import Data.Nat
+import Text.Measure
+
+%default total
+
+||| Core drawing settings used for computing the geometric properties of
+||| drawn molecules.
+public export
+record CoreDims where
+ [noHints]
+ constructor CD
+ radiusAtom : Double
+ bondWidth : Double
+ bondBGWidth : Double
+ selectBufferSize : Double
+ angleSteps : Nat
+ font : String
+ fontSize : Nat
+ subscriptSize : Nat
+
+ ||| Gap between two bars of a downward facing wedge
+ downWedgeGap : Double
+
+ ||| Width of the narrow end of a wedge
+ wedgeNarrowEnd : Double
+
+ ||| Width of the wide end of a wedge
+ wedgeWideEnd : Double
+
+ ||| Half the wavelength of a wavy bond
+ halfWaveLength : Double
+
+ ||| Amplitude of a wavy bond
+ waveAmplitude : Double
+
+ ||| Utility used for measuring text
+ measure : Measure
+
+ 0 stepsPrf : IsSucc angleSteps
+
+export
+defaultCore : CoreDims
+defaultCore =
+ CD
+ { radiusAtom = 5.0
+ , bondWidth = 1.0
+ , bondBGWidth = 4.0
+ , selectBufferSize = 10.0
+ , angleSteps = 24
+ , stepsPrf = ItIsSucc
+ , font = "Arial, Helvetica, 'Liberation Sans', sans-serif"
+ , fontSize = 11
+ , subscriptSize = 7
+ , downWedgeGap = 2.0
+ , wedgeNarrowEnd = 0.1
+ , wedgeWideEnd = 5
+ , halfWaveLength = 2.5
+ , waveAmplitude = 1.5
+ , measure = defaultMeasure
+ }
diff --git a/src/CyBy/Draw/Internal/DoubleBond.idr b/src/CyBy/Draw/Internal/DoubleBond.idr
new file mode 100644
index 0000000..303854c
--- /dev/null
+++ b/src/CyBy/Draw/Internal/DoubleBond.idr
@@ -0,0 +1,135 @@
+||| This module containes the logic for properly placing double bonds, especiall
+||| the pi-part of those bonds. We use a simple heuristic to place the pi-bond:
+|||
+||| In case of a double bond with three substituents, the pi bond will be placed
+||| on the same side of the sigma bond as the lone substituent.
+|||
+||| In case of a double bond with four substituents, the dominant cycle
+||| (if any; see below) will be determined, and the pi-bond will be placed
+||| within that cycle.
+|||
+||| In all other cases, a symmetric double with both lines being displaced
+||| from the center by the same amount of space, will be displayed.
+|||
+||| In order to define the dominant cycle to which a double bond belongs,
+||| rings will be sorted by number of multiple bonds and then by ring size.
+||| Six membered rings will always be preferred over other ring sizes.
+module CyBy.Draw.Internal.DoubleBond
+
+import Derive.Prelude
+import Data.Graph.Indexed.Query.BFS
+import CyBy.Draw.Internal.Atom
+import CyBy.Draw.Internal.CoreDims
+import CyBy.Draw.Internal.Graph
+import CyBy.Draw.Internal.Label
+import Geom
+import Text.Molfile
+
+%default total
+%language ElabReflection
+
+--------------------------------------------------------------------------------
+-- Rings
+--------------------------------------------------------------------------------
+
+-- A data type for sorting rings by number of double- and triple bonds and by
+-- size, so that six-membered rings will always be preferred.
+data RingSize : Type where
+ NoRing : RingSize
+ Ring : (multibonds, size : Nat) -> RingSize
+ Hexane : (multibonds : Nat) -> RingSize
+
+%runElab derive "RingSize" [Eq,Ord]
+
+--------------------------------------------------------------------------------
+-- Geometry
+--------------------------------------------------------------------------------
+
+export
+parallelLine :
+ (r : Double)
+ -> (pos : Bool)
+ -> (x,y : Point Id)
+ -> (Point Id, Point Id)
+parallelLine r b x y =
+ (perpendicularPoint x y r b, perpendicularPoint y x r $ not b)
+
+
+||| Distance between the lines of a double or triple bond.
+export %inline
+ParallelDistance : (cd : CoreDims) => Double
+ParallelDistance = 0.8 * cd.radiusAtom
+
+||| Half the distance between the lines of a double or triple bond.
+export %inline
+HalfParallelDistance : (cd : CoreDims) => Double
+HalfParallelDistance = 0.5 * ParallelDistance
+
+-- `ox` and `oy` are the original positions of the atoms,
+-- while `px` and `py` are the visible bond endings.
+parameters {auto cd : CoreDims}
+ {k : Nat}
+ (g : CDIGraph k)
+ (x,y : Fin k)
+ (ox,oy,px,py : Point Id)
+
+ countMBs : Nat -> List (Fin k) -> Nat
+ countMBs n (a::t@(b::_)) =
+ case (type . molBond) <$> elab g a b of
+ Just Dbl => countMBs (S n) t
+ Just Triple => countMBs (S n) t
+ _ => countMBs n t
+ countMBs n _ = n
+
+ ringSize : (nx,ny : Fin k) -> RingSize
+ ringSize nx ny =
+ case limitedBfs g [x,y] nx ny of
+ Nothing => NoRing
+ Just sn =>
+ let path := x :: (sn <>> [y])
+ mbs := countMBs 0 path
+ in case length path of
+ 6 => Hexane mbs
+ n => Ring mbs n
+
+ displace : Vector Id
+ displace = scaleTo (tan (pi / 6) * ParallelDistance) (oy - ox)
+
+ dx : Point Id
+ dx = if ox == px then translate displace ox else px
+
+ dy : Point Id
+ dy = if oy == py then translate (negate displace) oy else py
+
+ deflt : Vect 4 (Point Id)
+ deflt =
+ let (v,w) := parallelLine HalfParallelDistance True px py
+ (x,y) := parallelLine HalfParallelDistance False px py
+ in [v,w,x,y]
+
+ notXorY : Fin k -> Bool
+ notXorY n = n /= x && n /= y
+
+ leftOfY : Angle -> Fin k -> Bool
+ leftOfY phi n =
+ let Just chi := angle (pointAt g n - px) | Nothing => False
+ in chi - phi <= Angle.pi
+
+ dominantNode : Fin k -> Vect 4 (Point Id)
+ dominantNode n =
+ let Just phi := angle (py - px) | Nothing => deflt
+ (v,w) := parallelLine ParallelDistance (leftOfY phi n) dx dy
+ in [px,py,v,w]
+
+ export
+ dblBond : Vect 4 (Point Id)
+ dblBond =
+ case (filter (y /=) (neighbours g x), filter (x /=) (neighbours g y)) of
+ ([nx1,nx2],[ny1,ny2]) =>
+ let r1 := max (ringSize nx1 ny1) (ringSize nx2 ny1)
+ r2 := max (ringSize nx1 ny2) (ringSize nx2 ny2)
+ in if r1 >= r2 then dominantNode ny1 else dominantNode ny2
+ ([_,_],[ny]) => dominantNode ny
+ ([nx], [_,_]) => dominantNode nx
+ ([nx], [_]) => dominantNode nx
+ _ => deflt
diff --git a/src/CyBy/Draw/Internal/Graph.idr b/src/CyBy/Draw/Internal/Graph.idr
new file mode 100644
index 0000000..c7439ec
--- /dev/null
+++ b/src/CyBy/Draw/Internal/Graph.idr
@@ -0,0 +1,932 @@
+module CyBy.Draw.Internal.Graph
+
+import Chem.Util
+import CyBy.Draw.Internal.CoreDims
+import CyBy.Draw.Internal.Atom
+import CyBy.Draw.Internal.Role
+import Data.Graph.Indexed.Subgraph
+import Derive.Prelude
+import Geom
+import Text.Molfile
+
+%language ElabReflection
+%default total
+
+||| In several places, we decide what to do on a UI event
+||| based on whether any nodes or edges are selected or being
+||| hovered over.
+public export
+data NOE : (a,b : Type) -> Type where
+ None : NOE a b -- the empty case
+ N : a -> NOE a b -- the "nodes" case
+ E : b -> NOE a b -- the "edges" case
+
+||| Creates an `NOE` from two `Maybe`s.
+export
+noe : Maybe a -> Lazy (Maybe b) -> NOE a b
+noe mn me = maybe (maybe None E me) N mn
+
+||| Like `noe`, but edges take precedence.
+export
+eon : Lazy (Maybe a) -> Maybe b -> NOE a b
+eon mn me = maybe (maybe None N mn) E me
+
+||| Creates an `NOE` from two `Lists`s.
+|||
+||| This returns `None` in case both lists are empty.
+export
+eons : List a -> Lazy (List b) -> NOE (List a) (List b)
+eons _ es@(_::_) = E es
+eons ns [] = if null ns then None else N ns
+
+||| Bond type used in cyby-draw.
+|||
+||| This is an mol-file bond paired with a role used for drawing.
+public export
+record CDBond where
+ constructor CB
+ role : Role
+ molBond : MolBond
+
+%runElab derive "CDBond" [Show,Eq]
+
+export %inline
+Cast CDBond Role where cast = role
+
+export %inline
+ModRole CDBond where modRole f = {role $= f}
+
+||| Graph type used for drawing molecules.
+public export
+0 CDGraph : Type
+CDGraph = Graph CDBond CDAtom
+
+||| Order-indexed graph type used for drawing molecules.
+public export
+0 CDIGraph : Nat -> Type
+CDIGraph k = IGraph k CDBond CDAtom
+
+export %inline
+toMolGraph : Graph CDBond CDAtom -> MolGraphAT
+toMolGraph = bimap CDBond.molBond CDAtom.atom
+
+export %inline
+toMolfile : Graph CDBond CDAtom -> MolfileAT
+toMolfile = MkMolfile "" "created by cyby-draw 1.0" "" . toMolGraph
+
+||| Initialize a mol-file graph (with perceived atom types) to be used
+||| in one of the drawing canvases. This includes normalizing the
+||| molecule to a bond-length of 1.25 Angstrom.
+export
+initGraph : MolGraphAT -> CDGraph
+initGraph (G o g) = G o $ bimap (CB None) (CA None) (normalizeMol g)
+
+||| Reads and initializes a `CDGraph` from a mol-file string.
+export
+readMolfileE : String -> Either String CDGraph
+readMolfileE mol =
+ case readMol {es = [MolParseErr]} mol of
+ Left (Here e) => Left "\{e}"
+ Right (MkMolfile _ _ _ g) => Right $ initGraph (perceiveMolAtomTypes g)
+
+||| Like `readMolfileE` but returns the empty graph in case of a read error.
+export
+readMolfile : String -> CDGraph
+readMolfile = either (const $ G 0 empty) id . readMolfileE
+
+||| Re-calculates the atom types of a mol graph.
+export
+adjAtomTypes : {k : _} -> CDIGraph k -> CDIGraph k
+adjAtomTypes =
+ mapWithAdj (\(A (CA r a) ns) => CA r $ calcMolAtomType (map molBond ns) a)
+
+--------------------------------------------------------------------------------
+-- Bond CyCling
+--------------------------------------------------------------------------------
+
+adjStereo : BondStereo -> MolBond -> MolBond
+adjStereo Up (MkBond fs _ Up) = MkBond (not fs) Single Up
+adjStereo Down (MkBond fs _ Down) = MkBond (not fs) Single Down
+adjStereo bs b = MkBond True Single bs
+
+nextType : BondOrder -> BondOrder
+nextType Single = Dbl
+nextType Dbl = Triple
+nextType Triple = Single
+
+export
+newBond : BondOrder -> BondStereo -> MolBond -> MolBond
+newBond Single NoBondStereo b =
+ if b.stereo == NoBondStereo then cast $ nextType b.type else cast Single
+newBond Single s b = adjStereo s b
+newBond Dbl _ _ = cast Dbl
+newBond Triple _ _ = cast Triple
+
+--------------------------------------------------------------------------------
+-- Highlighting
+--------------------------------------------------------------------------------
+
+hlAdj : IArray o Bool -> Fin o -> Adj o CDBond CDAtom -> Adj o CDBond CDAtom
+hlAdj arr x (A l ns) =
+ case arr `at` x of
+ False => A l ns
+ True => A (set Highlight l) (mapKV (setIf Highlight . at arr) ns)
+
+||| Highlight the nodes corresponding to the given natural numbers.
+export
+highlight : List Nat -> CDGraph -> CDGraph
+highlight ns (G o $ IG gr) =
+ let arr := fromPairs o False (map (,True) ns)
+ in G o $ IG (mapWithIndex (hlAdj arr) gr)
+
+--------------------------------------------------------------------------------
+-- Visibility and Abbreviations
+--------------------------------------------------------------------------------
+
+||| Returns the number of the abbreviation group of an atom (if any).
+export %inline
+groupNr : CDIGraph k -> Fin k -> Maybe Nat
+groupNr g = map nr . label . atom . lab g
+
+||| True, if the given node is part of an abbreviation.
+export
+inAbbreviation : CDIGraph k -> Fin k -> Bool
+inAbbreviation g = isJust . groupNr g
+
+||| Returns the largest group number in the given graph.
+export %inline
+maxGroupNr : {k : _} -> CDIGraph k -> Nat
+maxGroupNr = foldr (\a,n => maybe n (max n . nr) a.atom.label) 0
+
+||| True, if any neighbour of the given node is part of the given
+||| abbreviation (given as its ID).
+export
+anyNotInGroup : CDIGraph k -> Fin k -> Nat -> Bool
+anyNotInGroup g x n = any (not . inGroup n) (neighbourLabels g x)
+
+||| Custom label to be displayed for a node (if any).
+export
+customLabel : CDIGraph k -> Fin k -> Maybe String
+customLabel g x = do
+ G n lbl <- label . atom $ lab g x
+ guard $ lbl /= "" && anyNotInGroup g x n
+ pure lbl
+
+||| An atom is visible, if a) it is not part of an abbreviation, or b),
+||| at least one of its neighbours is not part of an abbreviation.
+export
+visible : CDIGraph k -> Fin k -> Bool
+visible g x =
+ case Atom.label . atom $ lab g x of
+ Nothing => True
+ Just (G n _) => anyNotInGroup g x n
+
+||| We show an atom's label if a) it is a non-carbon, b) it is an isolate
+||| carbon (no explicit neighbours), or c) `s.showC` is set to `True`
+export
+labelVisible : (showC : Bool) -> CDIGraph k -> Fin k -> Bool
+labelVisible showC g x =
+ let A (CA _ a) ns := adj g x
+ MkI e m := a.elem
+ in showC
+ || null ns
+ || a.type.name == "C.allene"
+ || e /= C
+ || isJust m
+ || a.charge /= 0
+ || isJust (customLabel g x)
+
+||| Returns a list of those nodes of a molecule that will be visible
+||| in the drawing, that is, nodes that are not hidden because
+||| they are part of an abbreviation.
+export
+visibleNodes : {k : _} -> CDIGraph k -> List (Fin k)
+visibleNodes g = filter (visible g) (nodes g)
+
+nonAbbreviatedNodes : {k : _} -> CDIGraph k -> List (Fin k)
+nonAbbreviatedNodes g = filter (not . inAnyGroup . lab g) (nodes g)
+
+||| Returns the list of visible neighbours of an atome, that is,
+||| neighbours that are not hidded because they are part of an
+||| abbreviation.
+export
+visibleNeighbours : CDIGraph k -> Fin k -> List (Fin k)
+visibleNeighbours g x = filter (visible g) (neighbours g x)
+
+||| Returns a list of those nodes of a molecule that are hidden
+||| because they are part of an abbreviation.
+export
+hiddenNodes : {k : _} -> CDIGraph k -> List (Fin k)
+hiddenNodes g = filter (not . visible g) (nodes g)
+
+||| Returns a list of those edges of a molecule that will be visible
+||| in the drawing, that is, edges that are not hidden because
+||| they are part of an abbreviation.
+export
+visibleEdges : {k : _} -> CDIGraph k -> List (Edge k CDBond)
+visibleEdges g = filter (\(E x y _) => visible g x && visible g y) (edges g)
+
+||| Given a list `ns` of nodes in a molecule, returns a list containing
+||| also the other nodes belonging to the same abbreviations (if any)
+||| as the nodes in `ns`.
+||| transitively via abbreviations.
+export
+groupNodes : {k : _} -> CDIGraph k -> (ns : List (Fin k)) -> List (Fin k)
+groupNodes g ns =
+ let gs@(_::_) := ns >>= toList . groupNr g | Nil => Nil
+ in filter (any (`elem` gs) . groupNr g) (hiddenNodes g)
+
+||| Given a list `ns` of nodes in a molecule, returns a list containing
+||| also the other nodes belonging to the same abbreviations (if any)
+||| as the nodes in `ns`.
+||| transitively via abbreviations.
+export
+plusGroupNodes : {k : _} -> CDIGraph k -> (ns : List (Fin k)) -> List (Fin k)
+plusGroupNodes g ns = ns ++ groupNodes g ns
+
+--------------------------------------------------------------------------------
+-- Geometry
+--------------------------------------------------------------------------------
+
+||| Returns the position of the given node in a mol graph.
+export %inline
+pointAt : CDIGraph k -> Fin k -> Point Id
+pointAt g = pointId . lab g
+
+||| Computes the angles of all visible bonds connecting the given node.
+export
+bondAngles : CDIGraph k -> Fin k -> List Angle
+bondAngles g x =
+ let p := pointId (lab g x)
+ ns := lab g <$> visibleNeighbours g x
+ in mapMaybe (\k => angle $ pointId k - p) ns
+
+parameters {k : Nat}
+ {auto cd : CoreDims}
+
+ ||| Finds the visible node closest to the given point, but only
+ ||| if it is closer than the defined atom radius and it fulfills
+ ||| the given predicate.
+ export
+ closestNodeWhere : (Fin k -> Bool) -> Point Id -> CDIGraph k -> Maybe (Fin k)
+ closestNodeWhere pred p g = do
+ x <- minBy (distance p . pointId . lab g) . filter pred $ nodes g
+ let q := pointAt g x
+ guard $ near p q cd.radiusAtom
+ pure x
+
+ ||| Finds the visible node closest to the given point, but only
+ ||| if it is closer than the defined atom radius.
+ export %inline
+ closestNode : Point Id -> CDIGraph k -> Maybe (Fin k)
+ closestNode p g = closestNodeWhere (visible g) p g
+
+ ||| Finds the visible edge closest to the given point, but only
+ ||| if it is closer than the defined atom radius.
+ export
+ closestEdge : Point Id -> CDIGraph k -> Maybe (Edge k CDBond)
+ closestEdge p g = do
+ ed <- minBy distEdge $ visibleEdges g
+ guard $ distEdge ed <= cd.radiusAtom
+ pure ed
+
+ where
+ distEdge : Edge k n -> Double
+ distEdge (E x y _) = distanceToLineSegment p (pointAt g x) (pointAt g y)
+
+ ||| Returns the item (node or edge) closest to the current mouse position.
+ export
+ closestItem : Point Id -> CDIGraph k -> NOE (Fin k) (Edge k CDBond)
+ closestItem p g = noe (closestNode p g) (closestEdge p g)
+
+ ||| Generously approximates the bounds of an atom in the drawing.
+ export
+ approxBounds : CDIGraph k -> Fin k -> Bounds2D Id
+ approxBounds g x =
+ case visible g x of
+ False => neutral
+ True => case group $ lab g x of
+ Nothing =>
+ let r := 2 * cd.radiusAtom
+ P x y := pointAt g x
+ in BS (range (x-r) (x+r)) (range (y-r) (y+r))
+ Just (G _ l) =>
+ let w := cast {to = Double} (length l * cd.fontSize)
+ h := cast {to = Double} cd.fontSize
+ P x y := pointAt g x
+ in BS (range (x-w) (x+w)) (range (y-h) (y+h))
+
+--------------------------------------------------------------------------------
+-- Hovering
+--------------------------------------------------------------------------------
+
+||| Removes all roles from atoms and bonds in the given graph.
+export %inline
+clear : CDGraph -> CDGraph
+clear = bimap clear clear
+
+||| Unset all roles with the exception of `Hover` and `Selected`
+export %inline
+cleanup : CDGraph -> CDGraph
+cleanup = bimap (keep Persistent) (keep Persistent)
+
+%inline
+unHover : {k : _} -> CDIGraph k -> CDIGraph k
+unHover = bimap (unset Hover) (unset Hover)
+
+hoverE : Fin k -> Fin k -> Fin k -> Adj k CDBond CDAtom -> Adj k CDBond CDAtom
+hoverE x y z (A a ns) =
+ if x == z || y == z
+ then A a $ mapKV (\w => setIf Hover (w == x || w == y)) ns
+ else A a ns
+
+||| Adjusts the `Hovering` flag of all atoms and edges in the molecule.
+||| The visible atom closest to the given point is set to
+||| `Hover` if it is not further away than `radiusAtom`.
+|||
+||| Otherwise, the visible edge closest to the given point is set to
+||| `Hovering` if it is not further away than `radiusAtom`.
+|||
+||| If the atom, over which the mouse hovers is part of an abbreviation,
+||| all other atoms in the abbreviations will be set to `Hovering` as well.
+|||
+||| The `hatom` predicate is used to figure out if we can currently hover over
+||| a given atom.
+|||
+||| The `hbond` predicate is used to figure out if we can currently hover over
+||| a given bond (its bool argument should be `True`, if the bond is connected
+||| to at least one atom in an abbreviation group)
+export
+hover :
+ {k : _}
+ -> {auto cd : CoreDims}
+ -> (hbond : CDBond -> Bool-> Bool)
+ -> (hatom : CDAtom -> Bool)
+ -> Point Id
+ -> CDIGraph k
+ -> CDIGraph k
+hover hbond hatom p g0 =
+ let g := unHover g0
+ in case closestItem p g of
+ N n =>
+ if hatom (lab g n)
+ then mapWithCtxt (\x,(A a _) => setIf Hover (x == n) a) g
+ else g
+ E (E x y b) =>
+ if hbond b (inAnyGroup (lab g x) || inAnyGroup (lab g y))
+ then mapCtxt (hoverE x y) g
+ else g
+ None => g
+
+||| Adds the given role to the currently hovered atoms
+export %inline
+ifHover : Role -> CDGraph -> CDGraph
+ifHover r = map (\x => setIf r (is Hover x) x)
+
+||| Returns the currently hovered edges or atoms atoms
+export %inline
+hoveredItem : {k : _} -> CDIGraph k -> NOE (Fin k, CDAtom) (Edge k CDBond)
+hoveredItem g =
+ eon (find (is Hover . snd) (labNodes g)) (find (is Hover . label) (edges g))
+
+||| Selects the currently hovered atoms and bonds.
+|||
+||| The `SelectMode` flags indicate, if currently selected items should
+||| be kept or not, or if no item should be selected at all. The first
+||| value is used for edge selection and the second for node selection.
+export %inline
+selectHovered : SelectMode -> SelectMode -> CDGraph -> CDGraph
+selectHovered em nm = bimap (selectIfHovered em) (selectIfHovered nm)
+
+--------------------------------------------------------------------------------
+-- Selecting Nodes
+--------------------------------------------------------------------------------
+
+public export
+record SelectZones where
+ constructor SZ
+ dragUL : Point Id -- upper left corner for dragging
+ dragLR : Point Id -- lower right corner for dragging
+ rotUL : Point Id -- upper left corner for rotating
+ rotLR : Point Id -- lower right corner for rotating
+
+||| Selects all nodes that are a) currently being hovered over, or visible
+||| and in the given rectangle.
+export
+select : (start,end : Point Id) -> CDGraph -> CDGraph
+select s e (G o g) = G o $ mapWithCtxt sel g
+ where
+ sel : Fin o -> Adj o CDBond CDAtom -> CDAtom
+ sel n (A a _) =
+ let p := pointId a
+ in setIf Selected (is Hover a || (visible g n && inRectangle p s e)) a
+
+||| Returns `True` if the given node is currently selected.
+|||
+||| In case the `includeEdges` flag is set to `True`, this will also
+||| return `True` if one of the edges connecting the node is currently
+||| selected.
+export
+isSelected : CDIGraph k -> (includeEdges : Bool) -> Fin k -> Bool
+isSelected g include n =
+ let A a bs := adj g n
+ in is Selected a || (include && any (is Selected) bs)
+
+||| The list of currently selected nodes.
+export
+selectedNodes : {k : _} -> CDIGraph k -> (includeEdges : Bool) -> List (Fin k)
+selectedNodes g include = filter (isSelected g include) (nodes g)
+
+||| The list of currently selected edges.
+export
+selectedEdges : {k : _} -> CDIGraph k -> List (Fin k, Fin k)
+selectedEdges =
+ mapMaybe (\(E x y b) => if is Selected b then Just (x,y) else Nothing) . edges
+
+export
+selectedItems : {k : _} -> CDIGraph k -> NOE (List $ Fin k) (List (Fin k, Fin k))
+selectedItems g = eons (selectedNodes g False) (selectedEdges g)
+
+nodeBounds : CDIGraph k -> Fin k -> Bounds2D Mol
+nodeBounds g = bounds . lab g
+
+edgeBounds : CDIGraph k -> (Fin k,Fin k) -> Bounds2D Mol
+edgeBounds g (x,y) = bounds (lab g x) <+> bounds (lab g y)
+
+||| Computes the top left and bottom right corner of the bounding box
+||| containing the currently selected atoms (if any)
+export
+selectionCorners : CDGraph -> Maybe (Point Mol, Point Mol)
+selectionCorners (G o g) =
+ case selectedItems g of
+ N ns@(_ :: _ :: _) => corners $ foldMap (nodeBounds g) ns
+ E ps => corners $ foldMap (edgeBounds g) ps
+ _ => Nothing
+
+||| Checks, if there is enough space to grab the box in the canvas.
+export
+selectZones : (s : CoreDims) => (p1,p2 : Point Id) -> SelectZones
+selectZones p1 p2 =
+ let b := s.selectBufferSize
+ bs := bounds p1 <+> bounds p2
+
+ -- translation vector for the two corners of the inner buffer
+ -- this is zero if the bounding box formed by `p1` and `p2` is
+ -- already large enough, otherwise both dimensions are expanded as
+ -- needed
+ vd := scale 0.5 $ V (max 0 (b - width bs)) (max 0 (b - height bs))
+ vr := vid b b
+ d1 := translate (negate vd) p1
+ d2 := translate vd p2
+ in SZ d1 d2 (translate (negate vr) d1) (translate vr d2)
+
+--------------------------------------------------------------------------------
+-- Editing Molecules
+--------------------------------------------------------------------------------
+
+||| Creates an uncharged atom at the given position and with the given role.
+export
+isotopeAt : Isotope -> Point Id -> Role -> CDAtom
+isotopeAt i p r =
+ let pos := toCoords (convert p) [0,0,0]
+ in CA r (MkAtom i 0 pos NoRadical 0 unknown () Nothing)
+
+||| Creates an uncharged atom at the given position and with the given role.
+export %inline
+elemAt : Elem -> Point Id -> Role -> CDAtom
+elemAt = isotopeAt . cast
+
+||| Inserts an uncharged atom at the given position and with the given
+||| role.
+export %inline
+insIsotopeAt :
+ {k : _}
+ -> CDIGraph k
+ -> Isotope
+ -> Point Id
+ -> Role
+ -> CDIGraph (S k)
+insIsotopeAt g i p r = insNode g (isotopeAt i p r)
+
+||| Inserts an uncharged atom at the given position and with the given
+||| role.
+export %inline
+insElemAt : {k : _} -> CDIGraph k -> Elem -> Point Id -> Role -> CDIGraph (S k)
+insElemAt g = insIsotopeAt g . cast
+
+||| Computes the preferred angle for a new bond based on the bond type
+||| and angles to already existing bonds.
+export
+preferredAngle : (hasTriple : Bool) -> List Angle -> Angle
+preferredAngle _ [] = (negate 1.0 / 6.0) * pi
+preferredAngle True [x] = x + pi
+preferredAngle False [x] =
+ if (x >= zero && x <= halfPi) || (x >= pi && x <= threeHalfPi)
+ then x + twoThirdPi
+ else x - twoThirdPi
+preferredAngle _ xs = largestBisector xs
+
+||| Preferred position for a new atom bound to an existing one based on the
+||| largest bisector of angles between existing bonds
+export
+bestPos : CDIGraph k -> MolBond -> Fin k -> Point Id -> Point Id
+bestPos g b n p =
+ let hasTrpl := any ((Triple ==) . type) (b::map molBond (edgeLabels g n))
+ newAngle := preferredAngle hasTrpl (bondAngles g n)
+ in translate (polar BondLengthInPixels newAngle) p
+
+||| Equally spaced sequence of `s.angleSteps` angles from 0 until 2pi.
+export
+stepAngles : (s : CoreDims) => List Angle
+stepAngles =
+ let step = angle (TwoPi / cast s.angleSteps)
+ in map (\x => cast x * step) [0.. pred s.angleSteps]
+
+||| Suggested position for a new atom based on the current mouse position.
+||| The boolean flag indicates if "Shift" is currently down, in which case
+||| we just return the current point.
+export
+suggestedPos : CoreDims => Bool -> (atom, current : Point Id) -> Point Id
+suggestedPos True pa pc = pc
+suggestedPos False pa pc =
+ let Just mouseAngle := angle (pc - pa) | Nothing => pc
+ Just bondAngle := closestAngle mouseAngle stepAngles | Nothing => pc
+ in translate (polar BondLengthInPixels bondAngle) pa
+
+||| Draws a new bond from the given node to the suggested position.
+||| If another atom is already close to the current mouse position
+||| or the suggested position, connect the two atoms instead.
+export
+bondTo :
+ {k : _}
+ -> {auto s : CoreDims}
+ -> CDBond
+ -> Fin k
+ -> (current, suggested : Point Id)
+ -> CDIGraph k
+ -> Either (CDIGraph k) (CDIGraph $ S k)
+bondTo b n pc ps g =
+ maybe
+ (Right $ insEdge (edge n b) (insElemAt g C ps New))
+ (\e => Left $ insEdge e g)
+ (closeEdge pc <|> closeEdge ps)
+ where
+ closeEdge : Point Id -> Maybe (Edge k CDBond)
+ closeEdge p = closestNode p g >>= \k => mkEdge n k b
+
+||| From two graphs, returns pairs of visible nodes closest
+||| to each other (but no farther apart than `s.radiusAtom`).
+export
+nodesToMerge :
+ {k,m : _}
+ -> {auto s : CoreDims}
+ -> CDIGraph k
+ -> CDIGraph m
+ -> List (Fin k, Fin m)
+nodesToMerge g t =
+ mapMaybe
+ (\x => (x,) <$> closestNode (pointAt g x) t)
+ (nonAbbreviatedNodes g)
+
+-- Offset between origin atom and template atoms as a vector in `Mol` space.
+offset : CDIGraph k -> CDIGraph m -> List (Fin k, Fin m) -> Vector (transform Mol)
+offset _ _ [] = vzero
+offset g1 g2 ((n1,n2) :: _) = point (lab g1 n1) - point (lab g2 n2)
+
+-- create new bonds between the merging template atoms and the corresponding
+-- neighbours of the original molecule
+newEdges :
+ {k,m : _}
+ -> CDIGraph m
+ -> List (Fin k, Fin m)
+ -> List (Fin k, Fin m, CDBond)
+newEdges t ps = do
+ (a1,a2) <- ps
+ (\(x,l) => (a1,x,l)) <$> neighboursAsPairs t a2
+
+incNode : {m : _} -> (k : Nat) -> Fin m -> Maybe (Fin $ k + m)
+incNode k x = tryNatToFin (k + finToNat x)
+
+||| After moving or rotating the selected nodes in a graph,
+||| check for pairs of close nodes and merge them.
+export
+mergeCloseNodes : CoreDims => {k:_} -> CDIGraph k -> CDGraph
+mergeCloseNodes g =
+ let ns := filter (not . inAbbreviation g) (selectedNodes g True)
+ lMergeN := mapMaybe closestPair ns
+ offset := negate $ offset g g lMergeN
+ lnewBonds := mapMaybe (\(x,y,l) => mkEdge x y l) (newEdges g lMergeN)
+ mol' := insEdges lnewBonds $ mapIf doAdjust (translate offset) g
+ in delNodes (map snd lMergeN) mol'
+
+ where
+ canSelfMerge : Fin k -> Bool
+ canSelfMerge x =
+ let a := lab g x in not (isSelected g True x || inAnyGroup a)
+
+ doAdjust : CDAtom -> Bool
+ doAdjust a = is Selected a
+
+ closestPair : Fin k -> Maybe (Fin k, Fin k)
+ closestPair x = (x,) <$> closestNodeWhere canSelfMerge (pointAt g x) g
+
+export
+mergeGraphs' : CoreDims => {k,m:_} -> CDIGraph k -> CDIGraph m -> CDGraph
+mergeGraphs' g t =
+ let lMergeN := nodesToMerge g t
+ offset := offset g t lMergeN
+ lnewBonds := newEdges t lMergeN
+ mol' := mergeGraphsWithEdges g (translate offset t) lnewBonds
+ in delNodes (mapMaybe (incNode k . snd) lMergeN) mol'
+
+-- This connects a template to a graph by connecting the template's
+-- zero node via a single bond with the given node of the current molecule.
+-- The template is rotated and translated in such a way that we get
+-- preferrable bond angles both at the current graph and the template.
+mergeGraphsOnAtom : CoreDims => {k,m : _} -> Fin k -> CDIGraph k -> CDIGraph m -> CDGraph
+mergeGraphsOnAtom {m = 0} _ g _ = G _ g
+mergeGraphsOnAtom {m = S _} n g t =
+ case bondAngles g n of
+ [an] =>
+ let a0 := preferredAngle False (bondAngles t 0)
+ tr := rotate (an - a0) t
+ offset := point (lab g n) - point (lab tr 0)
+ in mergeGraphs' g (translate offset tr)
+ as =>
+ let an := preferredAngle False as
+ a0 := preferredAngle False (bondAngles t 0)
+ tr := rotate (an - a0 + pi) t
+ offset := point (lab g n) - point (lab tr 0)
+ v := polar BondLengthInAngstrom an + offset
+ bond := CB New $ cast Single
+ in G _ $ mergeGraphsWithEdges g (translate v tr) [(n,0,bond)]
+
+-- This connects a template to a graph by replacing the template's
+-- smallest edge given edge of the current molecule.
+-- The template is rotated and translated in such a way that the two
+-- edges are properly aligned.
+--
+-- There are two ways to align the bonds of template and
+-- molecule, so we try both and keep the one with its
+-- center closer to the mouse position. This allows us to
+-- flip between the two placements by moving the mouse
+-- from one side of a bond to the other.
+mergeGraphsOnBond :
+ {k,m : _}
+ -> {auto cd : CoreDims}
+ -> Point Mol
+ -> Edge k CDBond
+ -> CDIGraph k
+ -> CDIGraph m
+ -> CDGraph
+mergeGraphsOnBond p (E n1 n2 _) g t =
+ case edges t of
+ [] => G k g
+ E n3 n4 _ :: _ =>
+ let Just ag := angle (pointAt g n1 - pointAt g n2) | Nothing => G k g
+ Just at := angle (pointAt t n3 - pointAt t n4) | Nothing => G k g
+ tr1 := rotate (ag - at) t
+ tt1 := translate (point (lab g n1) - point (lab tr1 n3)) tr1
+ tr2 := rotate (ag - at + pi) t
+ tt2 := translate (point (lab g n1) - point (lab tr2 n4)) tr2
+ in if distance p (center tt1) <= distance p (center tt2)
+ then mergeGraphs' g tt1
+ else mergeGraphs' g tt2
+
+||| Add the template to the existing graph depending on clicking on an atom,
+||| a bond or elsewhere on the canvas.
+export
+mergeGraphs : CoreDims => Point Id -> (g, t : CDGraph) -> CDGraph
+mergeGraphs c (G o1 g) (G o2 t) =
+ case hoveredItem g of
+ N k => mergeGraphsOnAtom (fst k) g t
+ E e => mergeGraphsOnBond (convert c) e g t
+ None => mergeGraphs' g t
+
+||| Attaches an atom to a mol graph.
+|||
+||| Depending on the current mouse position and whether "Shift" is
+||| pressed or not, the drawing tool suggest a different bond length
+||| and angle for the new bond.
+export
+addBondE :
+ {k : _}
+ -> {t : _}
+ -> {auto cd : CoreDims}
+ -> (shiftDown : Bool)
+ -> (mousePos : Point t)
+ -> (newBond : MolBond)
+ -> CDIGraph k
+ -> Either (CDIGraph k) (CDIGraph $ S k)
+addBondE @{cd} shiftDown p mb g =
+ let b := CB New mb -- new `CDBond`
+ Just (n,a) := find (is Origin . snd) (labNodes g) | Nothing => Left g
+ pc := pointId p -- current mouse position
+ pa := pointId a -- position of atom we attach new bond to
+ in if near pa pc cd.radiusAtom
+ -- if mouse is close to origin atom
+ -- use largest bisector as new bond angle and draw a bond
+ -- of preferred length
+ then bondTo b n pc (bestPos g mb n pa) g
+
+ -- else use an angle close to the one of the vector connecting
+ -- the origin atom and the mouse pointer, unless "Shift" is down,
+ -- in which case we use the mouse position without modification
+ else bondTo b n pc (suggestedPos shiftDown pa pc) g
+
+||| Attaches an atom to a mol graph.
+|||
+||| Depending on the current mouse position and whether "Shift" is
+||| pressed or not, the drawing tool suggest a different bond length
+||| and angle for the new bond.
+export
+addBond :
+ {k : _}
+ -> {t : _}
+ -> {auto cd : CoreDims}
+ -> (shiftDown : Bool)
+ -> (mousePos : Point t)
+ -> (newBond : MolBond)
+ -> CDIGraph k
+ -> CDGraph
+addBond sd p mb g = either (G k) (G $ S k) (addBondE sd p mb g)
+
+||| Adds an uncharged atom of the given isotope at the given position.
+|||
+||| This either replaces the currently hovered atom, or it inserts a new
+||| isolate atom.
+export
+addAtom :
+ {auto cd : CoreDims}
+ -> {t : _}
+ -> {k : _}
+ -> CDIGraph k
+ -> Isotope
+ -> Point t
+ -> CDGraph
+addAtom g i p =
+ case hoveredItem g of
+ N (x,_) =>
+ let g2 := setNode x (isotopeAt i (pointAt g x) New) g
+ in delNodes (groupNodes g [x]) g2
+ _ => case closestNode (convert p) g of
+ Nothing => G _ $ insIsotopeAt g i (convert p) New
+
+ -- in the `Just` case, we have a node close to the mouse pointer
+ -- that is not set to "hovered". This means, replacing that node is
+ -- a non-op. We don't want to insert another atom on top of it, so
+ -- we return the graph unmodified.
+ Just _ => G _ g
+
+export
+setAbbreviationAt :
+ {auto cd : CoreDims}
+ -> {k,m : Nat}
+ -> (lbl : String)
+ -> (node,neigh : Fin k)
+ -> (abbr : CDIGraph (S m))
+ -> (mol : CDIGraph k)
+ -> CDGraph
+setAbbreviationAt lbl n1 n2 a g =
+ let nr := S (maxGroupNr g)
+ pn := point (lab g n1) -- position of label
+ pc := point (lab g n2) -- node to which label is connected
+ Just an := angle (pn - pc) | Nothing => G k g
+ a0 := preferredAngle False (bondAngles a 0)
+ ar := rotate (an-a0+pi) (setGroup (G nr lbl) <$> a)
+ at := translate (pn - point (lab ar 0)) ar
+ bond := CB New $ maybe (cast Single) molBond (elab g n1 n2)
+ gm := mergeGraphsWithEdges g at [(n2,0,bond)]
+ in delNodes (plusGroupNodes gm [weakenN _ n1]) gm
+
+||| Replaces the atom or abbreviation at the given position with
+||| an abbreviation.
+export
+setAbbreviation :
+ {auto cd : CoreDims}
+ -> (shiftDown : Bool)
+ -> (lbl : String)
+ -> (mouse : Point Id)
+ -> (abbr : CDGraph)
+ -> (mol : CDGraph)
+ -> CDGraph
+setAbbreviation _ lbl mouse (G 0 _) g = g
+setAbbreviation sd lbl mouse (G (S m) a) (G k g) =
+ case find (is Origin . snd) (labNodes g) of
+ Nothing => G k g
+ Just (n1,_) => case visibleNeighbours g n1 of
+ [n2] => setAbbreviationAt lbl n1 n2 a g
+ _ => case addBondE sd mouse (cast Single) g of
+ Left _ => G k g
+ Right g2 => setAbbreviationAt lbl last (weaken n1) a g2
+
+||| Expands the currently hovered-over abbreviation (if any)
+export
+expand : CDGraph -> CDGraph
+expand (G o g) =
+ let N (n1,CA _ a) := hoveredItem g | _ => G o g
+ Just (G n _) := label a | _ => G o g
+ in G o $ map (clearGroup n) g
+
+%inline new : CDBond -> CDBond
+new = {role := New}
+
+%inline translateTemplateAtom : Vector (transform Mol) -> CDAtom -> CDAtom
+translateTemplateAtom v (CA _ a) = CA None $ translate v a
+
+||| Merges a template graph with the current mol graph based on the
+||| current mouse position.
+export
+addTemplate : CoreDims => {s : _} -> Point s -> (t, mol : CDGraph) -> CDGraph
+addTemplate p t mol =
+ let v := convert p - center t
+ in mergeGraphs (convert p) mol (bimap new (translateTemplateAtom v) t)
+
+||| Remove the abbreviation labels from orphaned abbreviation atoms.
+||| The list of nodes have had an edge remove and now belong to potentially
+||| orphaned abbreviation groups.
+export
+clearOrphanGroups : {k : _} -> List (Fin k) -> CDIGraph k -> CDIGraph k
+clearOrphanGroups ns g =
+ let gs@(_::_) := ns >>= toList . groupNr g | Nil => g
+ in map (\x => foldl (flip clearGroup) x gs) g
+
+||| Deletes all selected nodes or edge from the graph
+||| (including nodes selected transitively via abbreviations).
+|||
+||| When we delete an edge, we are at risk of creating an orphaned
+||| abbreviation: An invisible set of abbreviated nodes no longer
+||| connected to the visible part of the molecule. In such a case,
+||| we could either delete the whole abbreviation, or make the
+||| orphaned nodes visible. Here, we opt for the latter. If users
+||| want to delete the whole abbreviation, they can do so by
+||| deleting the atom in question.
+export
+deleteSelected : CDGraph -> CDGraph
+deleteSelected (G o g) =
+ case selectedItems g of
+ None => G o g
+ N ns => delNodes (plusGroupNodes g ns) g
+ E es =>
+ let ns := es >>= \(x,y) => [x,y]
+ in G o $ clearOrphanGroups ns (delEdges es g)
+
+mapNodeIf : {k : _} -> (Fin k -> Bool) -> (n -> n) -> IGraph k e n -> IGraph k e n
+mapNodeIf p f = mapWithCtxt (\n,a => if p n then f a.label else a.label)
+
+groupSelected : CDIGraph k -> List Nat -> Fin k -> Bool
+groupSelected g ns n =
+ let (CA _ a) := lab g n
+ in isSelected g True n || any ((`elem` ns) . nr) a.label
+
+||| Translates the selected atoms in a molecule by a vector given
+||| as a start and end point.
+export
+moveSelected : CoreDims => (start, end : Point Mol) -> CDGraph -> CDGraph
+moveSelected start end (G o g) =
+ let gs := selectedNodes g True >>= toList . groupNr g
+ in mergeCloseNodes $ mapNodeIf (groupSelected g gs) (translate $ end - start) g
+
+export
+rotateTempl :
+ {auto cd : CoreDims}
+ -> Bool
+ -> (start, end : Point Mol)
+ -> CDGraph
+ -> CDGraph
+rotateTempl cont start end g =
+ let Just d := angle (end - start) | Nothing => g
+ phi := fromMaybe d (closestAngle d $ if cont then [] else stepAngles)
+ in rotateAt start phi g
+
+||| Rotates the selected atoms around the center of the selection
+||| by an angle defined by the two points.
+|||
+||| If the `Bool` argument is set to `False`, we use step-wise rotation
+||| as defined in the `CoreDims` argument, otherwise, we use
+||| continuous rotation.
+export
+rotateSelected :
+ {auto cd : CoreDims}
+ -> Bool
+ -> (start, end : Point Mol)
+ -> CDGraph
+ -> CDGraph
+rotateSelected cont start end (G o g) =
+ let ns := selectedNodes g True
+ c := center $ foldMap (bounds . lab g) ns
+ Just ae := angle (end - c) | Nothing => G o g
+ Just as := angle (start - c) | Nothing => G o g
+ d := ae - as
+ phi := fromMaybe d (closestAngle d $ if cont then [] else stepAngles)
+ gs := ns >>= toList . groupNr g
+ in mergeCloseNodes $ mapNodeIf (groupSelected g gs) (rotateAt c phi) g
+
+||| Extracts the selected subgraph (or the whole graph, if no atoms are
+||| selected) from a drawing graph.
+export
+selectedSubgraph : (includeEmptySelection : Bool) -> CDGraph -> CDGraph
+selectedSubgraph b (G o g) =
+ case plusGroupNodes g (selectedNodes g False) of
+ [] => if b then G o g else G 0 empty
+ ns => snd <$> subgraphL g ns
diff --git a/src/CyBy/Draw/Internal/Label.idr b/src/CyBy/Draw/Internal/Label.idr
new file mode 100644
index 0000000..4f528dc
--- /dev/null
+++ b/src/CyBy/Draw/Internal/Label.idr
@@ -0,0 +1,379 @@
+module CyBy.Draw.Internal.Label
+
+import CyBy.Draw.Internal.Atom
+import CyBy.Draw.Internal.CoreDims
+import CyBy.Draw.Internal.Graph
+import Data.Finite
+import Geom
+import Text.Measure
+import Text.Molfile
+
+%default total
+
+-- Radius of (possibly) colored background circles around atom labels
+bgRadiusFactor : Double
+bgRadiusFactor = 0.7 -- 0.5 * sqrt 2
+
+export %inline
+lineEndRadius : Double
+lineEndRadius = 0.5
+
+--------------------------------------------------------------------------------
+-- Implicit Hydrogen position
+--------------------------------------------------------------------------------
+
+||| Position of implicit hydrogen label.
+||| These are placed in such a way that they interfere as little as
+||| possible with the bonds leading to an atom's neighbours
+public export
+data HPos = NoH | N | W | S | E
+
+--------------------------------------------------------------------------------
+-- Measured Text Labels
+--------------------------------------------------------------------------------
+
+||| A text label together with the text metrics we need to properly
+||| center it around its position `pos`
+public export
+record Text a where
+ constructor T
+ fsize : Nat
+ text : String
+ pos : a -- Position (center) of the text label
+ dims : TextDims
+
+export
+(.h) : Text a -> Double
+t.h = t.dims.capHeight
+
+export
+(.lh) : Text a -> Double
+t.lh = t.dims.lineHeight
+
+export
+(.w) : Text a -> Double
+t.w = t.dims.txtWidth
+
+public export
+Bounded (Text $ Point Id) where
+ btrans = Id
+ bounds (T _ "" _ _) = neutral
+ bounds (T _ _ (P x y) (TD _ cs w)) =
+ BS (range (x-w/2) (x+w/2)) (range (y-cs/2) (y+cs/2))
+
+||| The empty text label
+export
+noLbl : Text ()
+noLbl = T 0 "" () (TD 0 0 0)
+
+||| Returns a `Label` for a string together with its `TextDims`
+export
+text : (cd : CoreDims) => (sub : Bool) -> (text : String) -> Text ()
+text _ "" = noLbl
+text sub s =
+ let fs := if sub then cd.subscriptSize else cd.fontSize
+ in T fs s () $ cd.measure.measure fs cd.font s
+
+||| Computes the radius of the background circle of a text label.
+export
+radius : Text a -> Maybe Double
+radius (T _ "" _ _) = Nothing
+radius (T _ _ _ $ TD _ cs w) = Just $ max cs w * bgRadiusFactor
+
+trans : Vector Id -> Double -> Maybe Double -> Point Id -> Point Id
+trans v l Nothing x = x
+trans v l (Just r) x = translate (scale (r / l) v) x
+
+||| Adjusts the end point of an edge based on the radius of
+||| their background labels.
+export
+adjEndPoints :
+ (x,y : Point Id)
+ -> (rx,ry : Maybe Double)
+ -> Maybe (Point Id, Point Id)
+adjEndPoints x y rx ry =
+ let v := x - y
+ lv := length v
+ True := lv > fromMaybe 0 rx + fromMaybe 0 ry | False => Nothing
+ in Just (trans (negate v) lv rx x, trans v lv ry y)
+
+||| Position where the text label should be placed in the canvas
+||| to correctly center it around the point given in its `pos` field
+export
+(.textPos) : Text (Point Id) -> Point Id
+l.textPos =
+ let P x y := l.pos
+ in P x (y + l.dims.capHeight / 2.0)
+
+||| Text labels for an atom's symbol, charge, mass number,
+||| implicit hydrogen, and implicit hydrogen count
+public export
+record AtomLabels a where
+ constructor AL
+ symbol : Text a
+ charge : Text a
+ mass : Text a
+ hydrogen : Text a
+ hcount : Text a
+
+export
+labels : AtomLabels a -> List (Text a)
+labels (AL v w x y z) = [v,w,x,y,z]
+
+public export
+Bounded (AtomLabels $ Point Id) where
+ btrans = Id
+ bounds = foldMap bounds . labels
+
+export
+chargeLabel : Charge -> String
+chargeLabel 0 = ""
+chargeLabel 1 = "+"
+chargeLabel (-1) = "-"
+chargeLabel n =
+ if n > 0 then "\{show n.value}+" else "\{show $ abs n.value}-"
+
+export
+massLabel : Maybe MassNr -> String
+massLabel = maybe "" (show . value)
+
+export
+hlabel : HCount -> String
+hlabel 0 = ""
+hlabel _ = "H"
+
+export
+hsubscript : HCount -> String
+hsubscript h = if h > 1 then show h.value else ""
+
+||| Compute the exact positions of all parts of an atom's labels based
+||| on the determined position of the hydrogen label (`HPos`), the position
+||| of the atom in the molecule, and the metrics of all labels we want
+||| to display.
+export
+setPositions : HPos -> Point Id -> AtomLabels () -> AtomLabels (Point Id)
+setPositions x p (AL s c m h hc) =
+ let -- displacement of the "H" label (if any)
+ vh := case x of
+ N => case c.h > 0.0 && hc.h > 0.0 of
+ True => vid 0 (negate $ s.h + (c.h + hc.h) / 2.0)
+ False => vid 0 (negate $ s.h + s.lh)
+ -- put H below atom label
+ S => vid 0 (h.h + h.lh)
+
+ -- put H left of atom label making space for hydrogen count
+ -- and mass number
+ W => vid (negate $ (s.w + h.w) / 2 + max hc.w m.w) 0
+
+ -- put H to the right of atom label
+ -- charge will come after H label.
+ _ => vid ((s.w + h.w) / 2) 0
+
+ -- displacement of the mass number label (if any)
+ vm := vid (negate $ (s.w + m.w) / 2) (m.h / 2 - s.h)
+
+ -- displacement of the charge label (if any)
+ vc := case x of
+ E => vid ((s.w + c.w) / 2 + h.w) (c.h / 2 - s.h)
+ _ => vid ((s.w + c.w) / 2) (c.h / 2 - s.h)
+
+ -- displacement of the H-count label (in case of more than 1 impl. H)
+ vhc := vid ((h.w + hc.w) / 2) (h.h / 2.0)
+
+ -- Text (Point Id) for the atom symbol
+ sym := {pos := p} s
+
+ -- Text (Point Id) for the "H" label
+ -- We must make sure this is at same textual height as the atom
+ -- symbol if we place it left or right of the atom symbol
+ hyd := {pos := translate vh p} h
+
+ in AL
+ { symbol = sym
+ , charge = {pos := translate vc p} c
+ , mass = {pos := translate vm p} m
+ , hydrogen = hyd
+ , hcount = {pos := translate vhc hyd.pos} hc
+ }
+
+--------------------------------------------------------------------------------
+-- Abbreviations
+--------------------------------------------------------------------------------
+
+public export
+data AbbrPos = AE | AW
+
+export
+abbrTextPos : CoreDims => AbbrPos -> Point Id -> Text () -> Text (Point Id)
+abbrTextPos @{cd} AE (P x y) t =
+ case t.w < 2*cd.radiusAtom of
+ True => {pos := P x y} t
+ False => {pos := P (x + t.w / 2.0 - cd.radiusAtom) y} t
+abbrTextPos @{cd} AW (P x y) t =
+ case t.w < 2*cd.radiusAtom of
+ True => {pos := P x y} t
+ False => {pos := P (x - t.w / 2.0 + cd.radiusAtom) y} t
+
+--------------------------------------------------------------------------------
+-- Updating Labels
+--------------------------------------------------------------------------------
+
+firstAfter : Eq a => a -> List a -> a
+firstAfter v vs =
+ case break (v ==) vs of
+ (_, _::x::_) => x
+ (x::_, [_]) => x
+ (x::_, []) => x
+ (_, _) => v
+
+getListElems : String -> List Elem
+getListElems s = filter (isPrefixOf s . show) values
+
+||| Based on a string input (currently, a single character) and the current
+||| element, selects the next element from all elements the symbol of which
+||| starts with the input character.
+|||
+||| This allows us to use keyboard shortcuts to change the element of the
+||| atom over which we currently hover.
+export
+updateElem : String -> Elem -> Elem
+updateElem s e = firstAfter e $ sortBy (comparing show) (getListElems s)
+
+||| Uses `updateElem` to change the element of an isotope.
+export
+updateIsotope : String -> Isotope -> Isotope
+updateIsotope s i = cast $ updateElem s i.elem
+
+export
+masses : Elem -> List (Maybe MassNr)
+masses e = Nothing :: sort (map (Just . massNr) $ isotopes e)
+
+isoList : Elem -> List Isotope
+isoList el = MkI el <$> masses el
+
+export
+incIso : Isotope -> Isotope
+incIso i = firstAfter i (isoList i.elem)
+
+export
+decIso : Isotope -> Isotope
+decIso i = firstAfter i (reverse $ isoList i.elem)
+
+--------------------------------------------------------------------------------
+-- Arbitrary Atomlabels
+--------------------------------------------------------------------------------
+
+public export
+data Label : Type where
+ Hidden : Label
+ NoLabel : Point Id -> Label
+ Abbreviation : Point Id -> Text (Point Id) -> Label
+ Explicit : AtomLabels (Point Id) -> Label
+
+public export
+0 Labels : Nat -> Type
+Labels k = IArray k Label
+
+circleBounds : (cd : CoreDims) => Point Id -> Bounds2D Id
+circleBounds (P x y) =
+ let r := cd.radiusAtom in BS (range (x-r) (x+r)) (range (y-r)(y+r))
+
+public export
+(cd : CoreDims) => Bounded Label where
+ btrans = Id
+ bounds Hidden = neutral
+ bounds (NoLabel p) = circleBounds p
+ bounds (Explicit x) = bounds x
+ bounds (Abbreviation _ x) = bounds x
+
+--------------------------------------------------------------------------------
+-- Bond End Points
+--------------------------------------------------------------------------------
+
+||| Given a starting point and a vector, tries to find the
+||| first intersection of the resulting line segment with a
+||| circle given by its center and radius.
+export
+trimToCircle :
+ Point t
+ -> Vector (transform t)
+ -> (c : Point t)
+ -> (r : Double)
+ -> Double
+trimToCircle (P x y) (V vx vy) (P cx cy) r =
+ let dx := x - cx
+ dy := y - cy
+ in case solveQuadratic (vx*vx+vy*vy) (2*(dx*vx+dy*vy)) (dx*dx+dy*dy-r*r) of
+ Nothing => 1.0
+ Just (s1,s2) => if s1 < 0 then if s2 >= 0 then 0 else 1 else min s1 1
+
+textFactor : Point Id -> Vector Id -> Text (Point Id) -> Double
+textFactor p v t =
+ case radius t of
+ Nothing => 1
+ Just r => trimToCircle p v t.pos (r + lineEndRadius)
+
+abbrFactor : CoreDims => Point Id -> Vector Id -> Point Id -> Double
+abbrFactor @{cd} p v q = trimToCircle p v q (cd.radiusAtom + 4 * lineEndRadius)
+
+factor : CoreDims => Point Id -> Vector Id -> Label -> Double
+factor p v Hidden = 0
+factor p v (NoLabel _) = 1
+factor p v (Abbreviation q _) = abbrFactor p v q
+factor p v (Explicit ls) = foldl min 1 (textFactor p v <$> labels ls)
+
+||| Computes the end points of a bond based on the atom positions and
+||| atom labels so that the bonds do not overlap with the labels.
+export
+endpoints :
+ {auto _: CoreDims}
+ -> (x,y : Point Id)
+ -> (lx,ly : Label)
+ -> Maybe (Point Id, Point Id)
+endpoints x y (NoLabel _) (NoLabel _) = Just (x,y)
+endpoints x y Hidden _ = Nothing
+endpoints x y _ Hidden = Nothing
+endpoints x y lx ly =
+ let vx := y - x
+ vy := x - y
+ fx := factor x vx ly
+ fy := factor y vy lx
+ in if fx + fy <= 1
+ then Nothing
+ else Just ( translate (scale (1-fy) vx) x
+ , translate (scale (1-fx) vy) y
+ )
+
+--------------------------------------------------------------------------------
+-- Label Positions
+--------------------------------------------------------------------------------
+
+||| Relative position, where the label of an abbreviated group will be
+||| placed.
+export
+abbrPos : CDIGraph k -> Fin k -> AbbrPos
+abbrPos g x =
+ let [a] := bondAngles g x | _ => AE
+ in if a <= halfPi || a >= (negate halfPi) then AW else AE
+
+||| Determines the position of the "H"-label depending on the angles of
+||| bonds leading to neighbours
+export
+bestHPos : List Geom.Angle.Angle -> HPos
+bestHPos xs =
+ if all (\x => x >= halfPi && x <= threeHalfPi) xs then E
+ else if all (\x => x <= halfPi || x >= threeHalfPi) xs then W
+ else if all (\x => x <= pi) xs then N
+ else if all (\x => x >= pi) xs then S
+ else E -- catch-all pattern for very crowded atoms
+
+||| Determines the position of the "H" label (if any)
+||| relative to an atom's symbol. To do this, this computes the angles
+||| of all bonds leading to an atom's neighbours and tries to find
+||| a direction (north, west, south, or east) without any neighbouring bonds
+export
+hpos : CDIGraph k -> Fin k -> HPos
+hpos g x =
+ case Atom.hydrogen . atom $ lab g x of
+ 0 => NoH
+ _ => bestHPos (bondAngles g x)
diff --git a/src/CyBy/Draw/Internal/Ring.idr b/src/CyBy/Draw/Internal/Ring.idr
new file mode 100644
index 0000000..824eea4
--- /dev/null
+++ b/src/CyBy/Draw/Internal/Ring.idr
@@ -0,0 +1,45 @@
+module CyBy.Draw.Internal.Ring
+
+import Data.Fin
+import Data.Array.Indexed
+import CyBy.Draw.Internal.Atom
+import CyBy.Draw.Internal.Graph
+import CyBy.Draw.Internal.Label
+import CyBy.Draw.Internal.Role
+import Geom
+import Text.Molfile
+
+%default total
+
+ringBonds : (n : Nat) -> List (Edge n CDBond)
+ringBonds n =
+ catMaybes $ natEdge 0 (pred n) :: map (\x => natEdge x (S x)) [0 .. pred n]
+ where
+ natEdge : Nat -> Nat -> Maybe (Edge n CDBond)
+ natEdge x y = do
+ fx <- tryNatToFin x
+ fy <- tryNatToFin y
+ mkEdge fx fy (CB None $ cast Single)
+
+add : Integer -> Double -> Double
+add n v = if n `mod` 2 == 0 then v / 2.0 else pi / (- 2.0)
+
+||| Creates a regular, saturated n-cycle of carbon atoms.
+export
+nring : (n : Nat) -> {auto 0 p : LT 2 n} -> CDIGraph n
+nring n =
+ let step := TwoPi / cast n
+ plus := add (cast n) step
+ as := generate n (\f => angle $ cast (cast {to = Nat} f) * step + plus)
+
+ -- length of vectors pointing from the origin to the points of the n-gon
+ -- this follows from `sine phi = opposite / hypotenuse`
+ l := scale $ value BondLengthInPixels / (2.0 * sin (step / 2.0))
+ in adjAtomTypes $ mkGraph
+ (toVect $ map (\a => elemAt C (translate (polar l a) origin) None) as)
+ (ringBonds n)
+
+||| Creates a regular, saturated n-cycle of carbon atoms.
+export
+ring : (n : Nat) -> {auto 0 p : LT 2 n} -> CDGraph
+ring n = G n $ nring n
diff --git a/src/CyBy/Draw/Internal/Role.idr b/src/CyBy/Draw/Internal/Role.idr
new file mode 100644
index 0000000..2bc20d2
--- /dev/null
+++ b/src/CyBy/Draw/Internal/Role.idr
@@ -0,0 +1,100 @@
+module CyBy.Draw.Internal.Role
+
+import Data.Bits
+import Derive.Prelude
+
+%default total
+%language ElabReflection
+
+||| The role(s) an object (typically an atom or bond) in the
+||| drawing currently has (for instance, it is selected, or
+||| the mouse hovers over it, or it is currently being drawn).
+|||
+||| We encode this as a bit pattern to facilitate adding new roles and
+||| having several roles set simultaneously.
+|||
+||| `Role` is a semigroup (using bitwise "or", `(.|.)`, for append) and
+||| a monoid, with 0 as the neutral element.
+public export
+record Role where
+ constructor R
+ role : Bits8
+
+%runElab derive "Role" [Show,Eq,Ord]
+
+export %inline
+Semigroup Role where
+ R x <+> R y = R (x .|. y)
+
+export %inline
+Monoid Role where neutral = R 0
+
+public export
+None, Hover, Selected, Origin, New, Persistent, HoverNew, Highlight : Role
+None = R 0
+Hover = R 1
+Selected = R 2
+Origin = R 4
+New = R 8
+Highlight = R 16
+Persistent = Hover <+> Selected
+HoverNew = Hover <+> New
+
+||| Interface for objects with a `Role` we can modify
+public export
+interface ModRole a where
+ modRole : (Role -> Role) -> a -> a
+
+export %inline
+ModRole Role where modRole f = f
+
+||| Sets the given role at an object in the drawing
+export
+setIf : ModRole a => Role -> Bool -> a -> a
+setIf r True = modRole (r <+>)
+setIf r False = modRole $ \(R y) => R (y `xor` (r.role .&. y))
+
+||| Sets the given role at an object in the drawing
+export %inline
+set : ModRole a => Role -> a -> a
+set r = r `setIf` True
+
+||| Sets the given role at an object in the drawing
+export %inline
+unset : ModRole a => Role -> a -> a
+unset r = r `setIf` False
+
+||| Keep only the given roles and unset all others
+export %inline
+keep : ModRole a => Role -> a -> a
+keep (R x) = modRole $ \(R y) => R (x .&. y)
+
+||| Completely remove all roles
+export %inline
+clear : ModRole a => a -> a
+clear = modRole (const None)
+
+||| Tests if the given role(s) is/are set at the given object
+||| in the drawing
+export
+is : Cast a Role => Role -> a -> Bool
+is (R x) v = (x .&. role (cast v)) == x
+
+||| Selection mode we are currently in.
+|||
+||| `Ignore` means that we are currently not selecting this type of item.
+||| `One` means "single-select" mode (SHIFT is not down)
+||| `Many` means "multi-select" mode (SHIFT is down)
+public export
+data SelectMode = Ignore | One | Many
+
+||| Selects a hovered node or edge.
+|||
+||| The boolean flag indicates, if we want to keep already selected
+||| node or not (as indicated by the `Shift` key being down).
+export
+selectIfHovered : ModRole a => SelectMode -> a -> a
+selectIfHovered Ignore = unset Selected
+selectIfHovered One = modRole (\x => setIf Selected (is Hover x) x)
+selectIfHovered Many =
+ modRole (\x => setIf Selected (is Hover x || is Selected x) x)
diff --git a/src/CyBy/Draw/Internal/Settings.idr b/src/CyBy/Draw/Internal/Settings.idr
new file mode 100644
index 0000000..212a346
--- /dev/null
+++ b/src/CyBy/Draw/Internal/Settings.idr
@@ -0,0 +1,77 @@
+module CyBy.Draw.Internal.Settings
+
+import CyBy.Draw.Internal.Abbreviations
+import CyBy.Draw.Internal.Color
+import CyBy.Draw.Internal.CoreDims
+import Text.SVG
+import Chem
+import Geom
+
+%default total
+
+--------------------------------------------------------------------------------
+-- Settings
+--------------------------------------------------------------------------------
+
+public export
+record DrawSettings where
+ [noHints]
+ constructor MS
+ core : CoreDims
+ abbreviations : List Abbreviation
+ bondColor : SVGColor
+ defaultBG : SVGColor
+ errorBG : SVGColor
+ highlightBG : SVGColor
+ hoverBG : SVGColor
+ newBG : SVGColor
+ originBG : SVGColor
+ selectBG : SVGColor
+ selectFG : SVGColor
+ showC : Bool
+ textColor : SVGColor
+ elemColor : Elem -> SVGColor -- color scheme to use
+ maxZoom : Scale
+ minZoom : Scale
+ pseFontSize : Nat
+
+export
+defaultSettings : List Abbreviation -> DrawSettings
+defaultSettings as =
+ MS {
+ abbreviations = as
+ , core = defaultCore
+ , hoverBG = RGBA 71 112 204 50.perc
+ , originBG = RGB 132 197 98
+ , newBG = lightgrey
+ , selectBG = RGBA 132 197 98 50.perc
+ , selectFG = RGBA 132 197 98 50.perc
+ , defaultBG = white
+ , highlightBG = lightgreen
+ , errorBG = RGB 255 150 150
+ , textColor = black
+ , elemColor = basicColors
+ , bondColor = black
+ , showC = False
+ , maxZoom = 20
+ , minZoom = 0.1
+ , pseFontSize = 11
+ }
+
+export %inline %hint
+toCoreDims : (ds : DrawSettings) => CoreDims
+toCoreDims = ds.core
+
+export
+(.selectBufferV) : DrawSettings -> Vector Id
+s.selectBufferV = vid s.core.selectBufferSize s.core.selectBufferSize
+
+||| Makes sure the given scaling factor does not exceed the valid
+||| zoom levels.
+export
+validScale : (s : DrawSettings) => AffineTransformation -> Scale -> Scale
+validScale t sc =
+ let tot := sc * t.transform.scale -- new scaling factor we would get
+ validTot := min (max tot s.minZoom) s.maxZoom -- valid scaling factor
+ False := validTot == tot | True => sc
+ in sc * scale (validTot.value / tot.value) -- adjust scale if result would be out of bounds
diff --git a/src/CyBy/Draw/Internal/Wedge.idr b/src/CyBy/Draw/Internal/Wedge.idr
new file mode 100644
index 0000000..aa3e15b
--- /dev/null
+++ b/src/CyBy/Draw/Internal/Wedge.idr
@@ -0,0 +1,96 @@
+module CyBy.Draw.Internal.Wedge
+
+import Geom
+import CyBy.Draw.Internal.CoreDims
+import CyBy.Draw.Internal.Label
+import Text.Molfile
+import Text.SVG
+
+%default total
+%hide Geom.Scale.(/)
+
+--------------------------------------------------------------------------------
+-- Util
+--------------------------------------------------------------------------------
+
+lineT : Point Id -> Point Id -> Maybe AffineTransformation
+lineT s e = (\phi => AT (rotation phi) (s - origin)) <$> angle (e - s)
+
+%inline
+transform : (t : AffineTransformation) -> Point Id -> Point t
+transform t = convert
+
+--------------------------------------------------------------------------------
+-- Wedges
+--------------------------------------------------------------------------------
+
+parameters {auto cd : CoreDims}
+
+ -- gap : initial gap (half the remaining distance)
+ -- bw : total bar width (stroke plus gap)
+ -- tot : total number of bars
+ -- x : index of current bar
+ downCmds : (gap,bw,tot : Double) -> AffineTransformation -> Double -> List PathCmd
+ downCmds gap bw tot t x =
+ let dw := cd.wedgeWideEnd - cd.wedgeNarrowEnd
+ l := cd.wedgeNarrowEnd + x * dw / tot -- current bar length
+ px := x * bw + gap
+ P x1 y1 := transform t $ P px (l/2.0)
+ P x2 y2 := transform t $ P px (l/(-2.0))
+ in [M x1 y1, L x2 y2]
+
+ ||| Generates evenly distributed bars for a downward wedge
+ ||| beween the two points.
+ |||
+ ||| This is a sequence of lines in an SVG ``.
+ export
+ wedgeDown : (start, end : Point Id) -> List PathCmd
+ wedgeDown s e =
+ let Just t := lineT s e | Nothing => []
+ len := distance s e -- distance between points
+ bw := cd.downWedgeGap + cd.bondWidth -- total bar width
+ True := len >= cd.bondWidth | False => []
+ tot := floor $ (len - cd.bondWidth) / bw
+ gap := (len - tot * bw) / 2.0
+ in [0..cast tot] >>= downCmds gap bw (1.0 + tot) t . cast
+
+ ||| Generates a wedged bond as a polygon.
+ export
+ wedgeUp : (s,e : Point Id) -> List (SVGAttribute "polygon") -> SVGNode
+ wedgeUp s e as =
+ let Just t := lineT s e | Nothing => Empty
+ len := distance s e
+ P a b := transform t $ P 0 (cd.wedgeNarrowEnd / 2.0)
+ P c d := transform t $ P 0 (cd.wedgeNarrowEnd / (-2.0))
+ P e f := transform t $ P len (cd.wedgeWideEnd / (-2.0))
+ P g h := transform t $ P len (cd.wedgeWideEnd / 2.0)
+ in polygon (points [a,b,c,d,e,f,g,h] :: as)
+
+--------------------------------------------------------------------------------
+-- Waved (zigzag) Bond
+--------------------------------------------------------------------------------
+
+ waves :
+ SnocList PathCmd
+ -> (gap : Double)
+ -> (pos : Bool)
+ -> AffineTransformation
+ -> List Nat
+ -> List PathCmd
+ waves sp gap pos t (a::tl) =
+ let P xa ya := transform t $ P (gap + cast a * cd.halfWaveLength) 0
+ cmd := A cd.waveAmplitude cd.waveAmplitude 0 False pos xa ya
+ in waves (sp :< cmd) gap (not pos) t tl
+ waves sp _ _ _ [] = sp <>> []
+
+ ||| Computes a "wavy" bond as a sequence of arcs on an SVG ``.
+ export
+ wave : (start,end : Point Id) -> List PathCmd
+ wave s e =
+ let Just t := lineT s e | Nothing => []
+ len := distance s e
+ True := len >= cd.halfWaveLength | False => []
+ tot := floor (len / cd.halfWaveLength)
+ gap := len - tot * cd.halfWaveLength
+ P x y := transform t $ P gap 0
+ in waves [ Mode
+ SetAbbr : Abbreviation -> Mode
+ SetTempl : CDGraph -> Mode
+ RotTempl : (start : Point Mol) -> CDGraph -> Mode
+ Selecting : (start : Point Id) -> Mode
+ Erasing : (start : Point Id) -> Mode
+ Dragging : (start : Point Mol) -> Mode
+ Rotating : (start : Point Mol) -> Mode
+ Translating : (prev : Mode) -> Mode
+ Drawing : Maybe Abbreviation -> Mode
+ PTable : (hovered : Maybe Elem) -> Mode
+
+%runElab derive "CyBy.Draw.MoleculeCanvas.Mode" [Show,Eq]
+
+endTranslate : Mode -> Mode
+endTranslate (Translating m) = m
+endTranslate m = m
+
+--------------------------------------------------------------------------------
+-- Hovering Rules
+--------------------------------------------------------------------------------
+
+sameAtom : Isotope -> CDAtom -> Bool
+sameAtom i a = elem a.atom == i && not (inAnyGroup a) && a.atom.charge == 0
+
+hoverAtom : Mode -> CDAtom -> Bool
+hoverAtom Select _ = True
+hoverAtom Erase _ = True
+hoverAtom Draw y = not (inAnyGroup y)
+hoverAtom (SetAtom x) y = not (sameAtom x y)
+hoverAtom (SetAbbr x) y = map lbl (group y) /= Just x.label
+hoverAtom (SetTempl x) y = not (inAnyGroup y)
+hoverAtom _ _ = False
+
+hoverDrawing : MolBond -> MolBond -> Bool -> Bool
+hoverDrawing (MkBond _ Single NoBondStereo) _ a = not a
+hoverDrawing (MkBond _ Single UpOrDown) b _ = b.stereo /= UpOrDown
+hoverDrawing (MkBond _ Single _) _ _ = True
+hoverDrawing (MkBond _ x _) b a = not a && b.type /= x
+
+hoverBond : Mode -> MolBond -> CDBond -> (inAbbreviation : Bool) -> Bool
+hoverBond Select _ _ _ = True
+hoverBond Erase _ _ _ = True
+hoverBond Draw mb b a = hoverDrawing mb b.molBond a
+hoverBond (SetTempl x) _ _ b = not b
+hoverBond _ _ _ _ = False
+
+--------------------------------------------------------------------------------
+-- Drawing State
+--------------------------------------------------------------------------------
+
+public export
+record DrawState where
+ [noHints]
+ constructor ST
+ dims : SceneDims
+ transform : AffineTransformation
+ curPos : Point transform
+ mol : CDGraph
+ undos : List (CDGraph)
+ redos : List (CDGraph)
+ mode : Mode
+ modifier : Modifier
+ bond : MolBond
+ abbr : Maybe Abbreviation
+ hasFocus : Bool
+ ptable : Maybe Elem
+
+ ||| Current SVG scene rendered to a string
+ ||| We keep track of this and the previous one to easily
+ ||| decide when to redraw the scene.
+ curSVG : String
+
+ ||| Previous SVG scene rendered to a string
+ prevSVG : String
+
+export %inline
+toMol : DrawState -> MolfileAT
+toMol ds = toMolfile ds.mol
+
+export %inline
+toMolStr : DrawState -> String
+toMolStr = writeMolfile . toMol
+
+export %inline
+(.imol) : (s : DrawState) -> CDIGraph s.mol.order
+s.imol = s.mol.graph
+
+--------------------------------------------------------------------------------
+-- State initialization
+--------------------------------------------------------------------------------
+
+||| Mode used to scale a molecule.
+|||
+||| This is used when centering a molecule, for instance, when we begin
+||| drawing, or when we just display a molecule and want to zoom in for it
+||| to fill the whole scene.
+public export
+data ScaleMode : Type where
+ ||| Scale mode used when initializing a scene for drawing
+ Init : ScaleMode
+
+ ||| Scale mode used when centering the molecule (by pressing the "reset" button)
+ Reset : ScaleMode
+
+ ||| Scale mode used when displaying a molecule so that it fills the whole
+ ||| scene
+ Fill : ScaleMode
+
+setTransform : AffineTransformation -> DrawState -> DrawState
+setTransform tr = {transform := tr, curPos $= convert}
+
+scaleTrans :
+ {auto ds : DrawSettings}
+ -> Point Id
+ -> Scale
+ -> AffineTransformation
+ -> AffineTransformation
+scaleTrans p sc t =
+ let v := p - origin
+ in translate v <+> scaling (validScale t sc) <+> translate (negate v) <+> t
+
+parameters {auto ds : DrawSettings}
+
+ export
+ scaleAt : Point Id -> Scale -> DrawState -> DrawState
+ scaleAt p sc s = setTransform (scaleTrans p sc s.transform) s
+
+ ||| Scales the molecule at the current mouse position.
+ export
+ scaleAtPos : Scale -> DrawState -> DrawState
+ scaleAtPos sc s = let P x y := s.curPos in scaleAt (P x y) sc s
+
+ ||| Scales the molecule at the center of the scene
+ export
+ scaleAtCenter : Scale -> DrawState -> DrawState
+ scaleAtCenter sc s = scaleAt (sceneCenter s.dims) sc s
+
+ scaleFromBounds : (scene,mol : Bounds2D Id) -> Scale
+ scaleFromBounds c m =
+ min (factor (width c) (width m)) (factor (height c) (height m))
+ where
+ factor : Double -> Double -> Scale
+ factor x y = scale $ (x / (y + 4.0 * cast ds.core.fontSize))
+
+ iniTrans : SceneDims -> ScaleMode -> CDGraph -> AffineTransformation
+ iniTrans sd sm (G _ g) =
+ let (bs,sc) := scaleToBounds
+ in scaleTrans (sceneCenter sd) sc $
+ translate (sceneCenter sd - convert (center bs))
+ where
+ scaleToBounds : (Bounds2D Id, Scale)
+ scaleToBounds =
+ case sm of
+ Init => (neutral,1.0)
+ Reset =>
+ let bs := foldMap bounds (Draw.labels g)
+ in (bs, min 1.0 (scaleFromBounds (sceneBounds sd) bs))
+ Fill =>
+ let bs = foldMap bounds (Draw.labels g)
+ in (bs, scaleFromBounds (sceneBounds sd) bs)
+
+ initAbbr : Maybe Abbreviation
+ initAbbr = case ds.abbreviations of {a :: _ => Just a; [] => Nothing}
+
+export
+(.posId) : DrawState -> Point Id
+s.posId = convert s.curPos
+
+export
+(.posMol) : DrawState -> Point Mol
+s.posMol = convert s.curPos
+
+--------------------------------------------------------------------------------
+-- Current Molecule
+--------------------------------------------------------------------------------
+
+-- Computes the molecule to be drawn based on the current
+-- state and mode. This is used both for displaying the current
+-- molecule in its editing state as well as for replacing the current
+-- molecule with its updated version when an editing step ends
+-- Using this for drawing allows us to not store additional information
+-- in the drawing mode.
+nextMol : DrawSettings => DrawState -> CDGraph
+nextMol s =
+ case s.hasFocus of
+ False => s.mol
+ True => case s.mode of
+ Select => s.mol
+ Erase => s.mol
+ Draw => s.mol
+ PTable _ => s.mol
+ SetAtom x => addAtom s.imol x s.curPos
+ SetAbbr _ => s.mol
+ Erasing p => select p s.posId s.mol
+ Translating _ => s.mol
+ Selecting p => select p s.posId s.mol
+ Dragging p => moveSelected p s.posMol s.mol
+ Rotating p => rotateSelected (s.modifier == Shift) p s.posMol s.mol
+ SetTempl t => addTemplate s.posMol t s.mol
+ RotTempl p t => addTemplate p (rotateTempl False p s.posMol t) s.mol
+ Drawing Nothing => addBond (s.modifier == Shift) s.posMol s.bond s.imol
+ Drawing (Just $ A l _ g) => setAbbreviation (s.modifier == Shift) l s.posId g s.mol
+
+--------------------------------------------------------------------------------
+-- Editing Molecule
+--------------------------------------------------------------------------------
+
+-- overwrites the current molecule, adding it to the `undo` stack
+updateMol : (CDGraph -> CDGraph) -> DrawState -> DrawState
+updateMol f s =
+ let G o g := f s.mol
+ cm := clear s.mol
+ in if clear (G o g) == cm then s else
+ { mol := G o $ adjAtomTypes g
+ , undos $= (cm ::), redos := []
+ } s
+
+-- adjusts the atoms fulfilling the given predicate with the given function
+-- this will delete any abbreviation associated with these atoms.
+modAtomWhere :
+ (CDAtom -> Bool)
+ -> (MolAtomAT -> MolAtomAT)
+ -> DrawState
+ -> DrawState
+modAtomWhere p f =
+ updateMol $ \(G o g) =>
+ let ns := filter (p . lab g) (nodes g)
+ in delNodes (groupNodes g ns) $ mapIf p {atom $= adj} g
+ where
+ adj : MolAtomAT -> MolAtomAT
+ adj = f . {label := Nothing}
+
+-- adjusts the currently hovered atom with the given function
+-- this will delete any abbreviation associated with the hovered atom.
+modAtom : (MolAtomAT -> MolAtomAT) -> DrawState -> DrawState
+modAtom = modAtomWhere (is Hover)
+
+%inline
+setMol : CDGraph -> DrawState -> DrawState
+setMol = updateMol . const
+
+-- delete the currently selected atoms
+%inline
+delete : DrawState -> DrawState
+delete = updateMol (clear . deleteSelected)
+
+--------------------------------------------------------------------------------
+-- Current Selection
+--------------------------------------------------------------------------------
+
+-- draws a rectangle around the currently selected atoms (if any),
+-- depending on whether the mouse is currently within the dragging zone
+drawSelection : (se : DrawSettings) => DrawState -> List SVGNode
+drawSelection s = case s.mode of
+ Erasing p => [fillRect se.selectFG p s.posId]
+ RotTempl p _ => rotateTemplScene p s.posMol
+ Selecting p => [fillRect se.selectFG p s.posId]
+ _ =>
+ -- tests if any atoms are selected and if that's the case, whether
+ -- the mouse is currently in the dragging zone.
+ case selectionCorners (nextMol s) of
+ Nothing => []
+ Just (p1,p2) =>
+ let SZ d1 d2 r1 r2 := selectZones (convert p1) (convert p2)
+ in if inRectangle s.posId d1 d2
+ then [outlineRect se.hoverBG d1 d2]
+ else [outlineRectD se.hoverBG r1 r2]
+
+-----------------------------------------------------------------------------
+-- Update State
+-----------------------------------------------------------------------------
+
+reset : DrawSettings => DrawState -> DrawState
+reset s = {transform := iniTrans s.dims Reset s.mol, curPos := origin} s
+
+undo : DrawState -> DrawState
+undo s = case s.undos of
+ [] => s
+ (h::t) => {redos $= (clear s.mol ::), mol := h, undos := t} s
+
+redo : DrawState -> DrawState
+redo s = case s.redos of
+ [] => s
+ (h::t) => {undos $= (clear s.mol ::), mol := h, redos := t} s
+
+changeSelMode : DrawState -> DrawState
+changeSelMode s =
+ let mode := if s.modifier == Shift then Many else One
+ in case hoveredItem s.imol of
+ None => {mode := Selecting s.posId, mol $= selectHovered Ignore Ignore} s
+ N _ => {mode := Dragging s.posMol, mol $= selectHovered Ignore mode} s
+ E _ => {mode := Dragging s.posMol, mol $= selectHovered mode Ignore} s
+
+parameters {auto ds : DrawSettings}
+ -- Elaborates the current mode and elevates the fitting argument to a return
+ -- value
+ export
+ applyWhenSel :
+ {0 a : Type}
+ -> DrawState
+ -> (dragging : Lazy a)
+ -> (rotating : Lazy a)
+ -> (nothing : Lazy a)
+ -> a
+ applyWhenSel s d r n =
+ let pid := s.posId
+ in case hoveredItem s.imol of
+ None => case selectionCorners s.mol of
+ Nothing => n
+ Just (p1,p2) =>
+ let SZ d1 d2 r1 r2 := selectZones (convert p1) (convert p2)
+ in case inRectangle pid d1 d2 of
+ False => case inRectangle pid r1 r2 of
+ False => n
+ True => r
+ True => d
+ _ => n
+
+ -- When we move the mouse, we must adjust the current mouse position
+ -- in the application state. If the middle mouse button is pressed,
+ -- we also translate the drawing area, otherwise we adjust the hovering
+ -- state of atoms.
+ move : (s : DrawState) -> Point s.transform -> DrawState
+ move s p =
+ case s.mode of
+ Translating _ =>
+ let V x y := p - s.curPos
+ v := vid x y
+ in setTransform (translate v <+> s.transform) s
+ PTable m => {mode := PTable (hoveredElem s.dims p)} s
+ m =>
+ let G o g := s.mol
+ gh := hover (hoverBond m s.bond) (hoverAtom m) (convert p) g
+ in { mol := G o gh, curPos := p} s
+
+ -- Pressing the left button typically begins an editing step
+ -- If this step depends on the start and end position of the mouse,
+ -- we enter a new mode and finish editing on the `leftUp` event.
+ -- Otherwise (for instance, when setting the label of an atom at
+ -- the mouse position),
+ -- the modification happens immediately.
+ leftDown : DrawState -> DrawState
+ leftDown s =
+ let pid := s.posId
+ in case s.mode of
+ Select =>
+ applyWhenSel
+ s
+ (updateMode s (Dragging s.posMol))
+ (updateMode s (Rotating s.posMol))
+ (changeSelMode s)
+
+ Erase =>
+ case hoveredItem s.imol of
+ None => {mode := Erasing s.posId} s
+ N _ => delete $ {mol $= selectHovered Ignore One} s
+ E _ => delete $ {mol $= selectHovered One Ignore} s
+
+ Draw =>
+ case hoveredItem s.imol of
+ None => setMol (G _ $ insElemAt s.imol C pid HoverNew) s
+ N x =>
+ if isJust (groupNr s.imol (fst x))
+ then s
+ else {mode := Drawing Nothing, mol $= ifHover Origin} s
+ E (E x y $ CB r b) =>
+ let b2 := newBond s.bond.type s.bond.stereo b
+ in setMol (G _ $ insEdge (E x y $ CB r b2) s.imol) s
+
+ SetAtom i => setMol (cleanup $ nextMol s) s
+ SetAbbr a => {mode := Drawing (Just a), mol $= ifHover Origin} s
+ SetTempl t => setMol (cleanup $ nextMol s) $ {mode := SetTempl t} s
+ _ => s
+ where updateMode : DrawState -> Mode -> DrawState
+ updateMode s m = {mode := m} s
+
+ -- When the left mouse button is lifted, this ends an ongoing editing
+ -- or selection process. We typically overwrite the current molecule with
+ -- the freshly edited one, adjust the drawing roles of atoms and bonds, and
+ -- determine the currently hovered atom anew.
+ leftUp : DrawState -> DrawState
+ leftUp s =
+ case s.mode of
+ Selecting _ => {mode := Select, mol := cleanup (nextMol s)} s
+ Erasing _ => delete $ {mode := Erase, mol := cleanup (nextMol s)} s
+ Dragging _ => setMol (cleanup $ nextMol s) $ {mode := Select} s
+ Rotating _ => setMol (cleanup $ nextMol s) $ {mode := Select} s
+ Drawing (Just a) => setMol (cleanup $ nextMol s) $ {mode := SetAbbr a} s
+ Drawing Nothing => setMol (cleanup $ nextMol s) $ {mode := Draw} s
+ PTable (Just el) => {mode := SetAtom (cast el)} s
+ PTable Nothing => s
+ _ => {mol $= cleanup} s
+
+ %inline
+ zoomOut, zoomIn : (atPos : Bool) -> DrawState -> DrawState
+ zoomOut True = scaleAtPos 0.8
+ zoomOut False = scaleAtCenter 0.8
+
+ zoomIn True = scaleAtPos 1.25
+ zoomIn False = scaleAtCenter 1.25
+
+ifCtrl : (f,g : Lazy (DrawState -> DrawState)) -> DrawState -> DrawState
+ifCtrl f g s = if s.modifier == Ctrl then f s else g s
+
+setElemStr : String -> DrawState -> DrawState
+setElemStr s = modAtom {elem $= updateIsotope s, charge := 0}
+
+startTemplRot : DrawState -> Mode -> Mode
+startTemplRot s (SetTempl g) = RotTempl s.posMol g
+startTemplRot s m = m
+
+stopTemplRot : DrawSettings => DrawState -> Mode -> Mode
+stopTemplRot s (RotTempl p g) = SetTempl (rotateTempl False p s.posMol g)
+stopTemplRot s m = m
+
+onKeyDown, onKeyUp : DrawSettings => String -> DrawState -> DrawState
+onKeyDown "Escape" s = {mode := Select, mol $= clear} s
+onKeyDown "Delete" s = delete s
+onKeyDown "Shift" s = {modifier := Shift} s
+onKeyDown "Control" s = {modifier := Ctrl, mode $= startTemplRot s} s
+onKeyDown "Meta" s = {modifier := Ctrl, mode $= startTemplRot s} s
+onKeyDown "ArrowUp" s = modAtom {elem $= incIso} s
+onKeyDown "ArrowDown" s = modAtom {elem $= decIso} s
+onKeyDown "+" s = ifCtrl (zoomIn True) (modAtom {charge $= incCharge}) s
+onKeyDown "-" s = ifCtrl (zoomOut True) (modAtom {charge $= decCharge}) s
+onKeyDown "c" s = ifCtrl id (setElemStr "C") s
+onKeyDown "x" s = ifCtrl id (setElemStr "X") s
+onKeyDown "z" s = ifCtrl undo (setElemStr "Z") s
+onKeyDown "y" s = ifCtrl redo (setElemStr "Y") s
+onKeyDown x s = setElemStr (toUpper x) s
+
+onKeyUp "Shift" s = {modifier $= reset Shift} s
+onKeyUp "Control" s = {modifier $= reset Ctrl, mode $= stopTemplRot s} s
+onKeyUp "Meta" s = {modifier $= reset Ctrl, mode $= stopTemplRot s} s
+onKeyUp _ s = s
+
+enableAbbr : DrawState -> DrawState
+enableAbbr s =
+ case s.abbr of
+ Nothing => s
+ Just a => {mode := SetAbbr a, mol $= clear} s
+
+setMassNr : Maybe MassNr -> MolAtomAT -> MolAtomAT
+setMassNr m a = let MkI e _ := a.elem in {elem := MkI e m} a
+
+erase : DrawState -> DrawState
+erase s =
+ case selectedItems s.imol of
+ None => {mode := Erase} s
+ _ => delete s
+
+endResize : (h,w : Double) -> DrawState -> DrawState
+endResize h w s =
+ let sd := if h > 2 && w > 2 then SD {sheight = h - 2, swidth = w - 2} else s.dims
+ in {dims := sd} s
+
+upd : DrawSettings => DrawEvent -> DrawState -> DrawState
+upd (ZoomIn b) s = zoomIn b s
+upd (ZoomOut b) s = zoomOut b s
+upd LeftDown s = leftDown s
+upd LeftUp s = leftUp s
+upd (Move x y) s = move s (P x y)
+upd MiddleDown s = {mode $= Translating} s
+upd MiddleUp s = {mode $= endTranslate} s
+upd Undo s = undo s
+upd Redo s = redo s
+upd (SetElem e) s = {mode := SetAtom (cast e), mol $= clear} s
+upd (ChgElem v) s = modAtomWhere (is Selected) {elem := cast v, charge := 0} s
+upd (ChgCharge v) s = modAtomWhere (is Selected) {charge := v} s
+upd (ChgMass v) s = modAtomWhere (is Selected) (setMassNr v) s
+upd (SetTempl e) s = {mode := SetTempl e, mol $= clear} s
+upd (SetBond b) s = {bond := b, mode := Draw, mol $= clear} s
+upd SelectMode s = {mode := Select} s
+upd (KeyDown x) s = onKeyDown x s
+upd (KeyUp x) s = onKeyUp x s
+upd EraseMode s = erase s
+upd Focus s = {hasFocus := True} s
+upd Blur s = {hasFocus := False} s
+upd Clear s = setMol (G 0 empty) s
+upd Expand s = updateMol expand s
+upd Center s = reset s
+upd EnableAbbr s = enableAbbr s
+upd (SelAbbr a) s = {mode := SetAbbr a, abbr := Just a, mol $= clear} s
+upd (Msg _) s = s
+upd EndResize s = s
+upd (EndResizeHW h w) s = endResize h w s
+upd StartPSE s = {mode := PTable Nothing} s
+
+||| Convert an `AffineTransformation` to a transformation to be
+||| used in an SVG element.
+export
+toTransform : AffineTransformation -> Transform
+toTransform (AT (LT s r) (V x y)) =
+ let co := s.value * cos r.value
+ si := s.value * sin r.value
+ in Matrix co si (negate si) co x y
+
+scene : DrawSettings => DrawState -> SVGNode
+scene s =
+ case s.mode of
+ PTable me => displayPSE s.dims me
+ _ =>
+ let m := nextMol s
+ in g
+ [transform $ toTransform s.transform]
+ (drawMolecule m ++ drawSelection s)
+
+display : DrawSettings => DrawState -> SVGNode
+display s =
+ svg
+ [ xmlns_2000
+ , width 100.perc
+ , height 100.perc
+ , viewBox 0.u 0.u s.dims.swidth.u s.dims.sheight.u
+ ] [scene s]
+
+export
+update : DrawSettings => DrawEvent -> DrawState -> DrawState
+update e s =
+ let s2 := upd e s
+ in {prevSVG := s.curSVG, curSVG := render (display s2)} s2
+
+--------------------------------------------------------------------------------
+-- Initialization
+--------------------------------------------------------------------------------
+
+parameters {auto ds : DrawSettings}
+
+ initST : SceneDims -> ScaleMode -> CDGraph -> DrawState
+ initST sd sm g =
+ ST
+ { dims = sd
+ , curPos = P (sd.swidth / 2.0) (sd.sheight / 2.0)
+ , transform = iniTrans sd sm g
+ , mol = g
+ , undos = []
+ , redos = []
+ , mode = Draw
+ , modifier = NoMod
+ , bond = MkBond False Single NoBondStereo
+ , abbr = initAbbr
+ , hasFocus = False
+ , ptable = Nothing
+ , curSVG = ""
+ , prevSVG = ""
+ }
+
+ ||| Initializes the drawing state for the given mol graph.
+ |||
+ ||| The `SceneDims` are used for centering the molecule, as well
+ ||| as for scaling it to fill the scene in case the given bool is
+ ||| set to `True`.
+ export
+ initMol : SceneDims -> ScaleMode -> CDGraph -> DrawState
+ initMol sd sm g =
+ let s := initST sd sm g
+ in {curSVG := render (display s)} s
+
+ export %inline
+ init : SceneDims -> ScaleMode -> String -> DrawState
+ init sd sm = initMol sd sm . readMolfile
+
+ export %inline
+ fromMol : SceneDims -> ScaleMode -> MolGraphAT -> DrawState
+ fromMol sd sm = initMol sd sm . initGraph
diff --git a/src/CyBy/Draw/PeriodicTableCanvas.idr b/src/CyBy/Draw/PeriodicTableCanvas.idr
new file mode 100644
index 0000000..335f251
--- /dev/null
+++ b/src/CyBy/Draw/PeriodicTableCanvas.idr
@@ -0,0 +1,147 @@
+module CyBy.Draw.PeriodicTableCanvas
+
+import Chem
+import CyBy.Draw.Internal.CoreDims
+import CyBy.Draw.Draw
+import CyBy.Draw.Event
+import CyBy.Draw.Internal.Settings
+import Data.Finite
+import Data.List
+import Data.Nat
+import Data.String
+import Derive.Prelude
+import Geom
+import Text.SVG
+import Text.SVG.Attribute as A
+
+%default total
+%language ElabReflection
+
+||| Dimensions of the SVG element (its `width` and `height`).
+public export
+record SceneDims where
+ constructor SD
+ swidth : Double
+ sheight : Double
+
+||| Center of the SVG scene.
+export
+sceneCenter : SceneDims -> Point Id
+sceneCenter sd = P (sd.swidth / 2.0) (sd.sheight / 2.0)
+
+||| Bounds of the SVG scene.
+export
+sceneBounds : SceneDims -> Bounds2D Id
+sceneBounds sd = BS (range 0.0 sd.swidth) (range 0.0 sd.sheight)
+
+--------------------------------------------------------------------------------
+-- PSE Cells
+--------------------------------------------------------------------------------
+
+public export
+record Cell where
+ constructor PC
+ element : Elem
+ ||| 0-based x-position in the periodic table.
+ posX : Nat
+
+ ||| 0-based y-position in the periodic table.
+ posY : Nat
+
+%runElab derive "Cell" [Show,Eq]
+
+xRelativeTo : Elem -> Elem -> Nat
+xRelativeTo x rel = cast $ conIndexElem x - conIndexElem rel
+
+public export
+PSERows, PSEColumns : Nat
+PSERows = 10
+PSEColumns = 18
+
+elemPosition : Elem -> (Nat,Nat)
+elemPosition H = (0,0)
+elemPosition He = (17,0)
+elemPosition Li = (0,1)
+elemPosition Be = (1,1)
+elemPosition Na = (0,2)
+elemPosition Mg = (1,2)
+elemPosition e =
+ if e >= B && e <= Ne then ((e `xRelativeTo` B) + 12,1)-- right part of 2nd period
+ else if e >= Al && e <= Ar then ((e `xRelativeTo` Al) + 12,2)-- right part of 3rd period
+ else if e >= K && e <= Kr then (e `xRelativeTo` K ,3)-- 4th period
+ else if e >= Rb && e <= Xe then (e `xRelativeTo` Rb ,4)-- 5th period
+ else if e >= Cs && e <= La then (e `xRelativeTo` Cs ,5)-- left part of 6th period
+ else if e >= Ce && e <= Lu then (e `xRelativeTo` Ba ,8)-- lanthanides
+ else if e >= Hf && e <= Rn then ((e `xRelativeTo` Hf) + 3,5)-- right part of 6th period
+ else if e >= Fr && e <= Ac then (e `xRelativeTo` Fr ,6)-- left part of 7th period
+ else if e >= Th && e <= Lr then (e `xRelativeTo` Ra ,9)-- actinides
+ else if e >= Rf && e <= Ts then ((e `xRelativeTo` Rf) + 3,6)-- right part of 7th period without Og
+ else (17,6)-- Og
+
+public export
+0 Cells : Type
+Cells = List Cell
+
+-- Generate a list of cells from the list of chemical elements
+-- (plus some info about the size of the canvas)
+public export
+cells : Cells
+cells =
+ map (\e => let (x,y) := elemPosition e in PC e x y) values
+
+--------------------------------------------------------------------------------
+-- Canvas Output
+--------------------------------------------------------------------------------
+
+half : Double
+half = 0.5
+
+hcell : Double
+hcell = 14.0
+
+wcell : Double
+wcell = 21.0
+
+parameters {auto s : DrawSettings}
+ (sd : SceneDims)
+
+ hcellRel : Double
+ hcellRel = sd.sheight / cast PSERows
+
+ wcellRel : Double
+ wcellRel = sd.swidth / cast PSEColumns
+
+ -- compute the position of the mouse in the PSE grid
+ -- this assume that the event was fired from the `HTMLCanvasElement`
+ -- we use for drawing the PSE
+ mousePos : (x,y : Double) -> (Nat,Nat)
+ mousePos x y = (cast $ x / wcellRel, cast $ y / hcellRel)
+
+ export
+ hoveredElem : {0 t : _} -> Point t -> Maybe Elem
+ hoveredElem (P dx dy) =
+ let (x,y) := mousePos dx dy
+ in element <$> find (\c => c.posX == x && c.posY == y) cells
+
+ drawCell : Maybe Elem -> Cell -> SVGNode
+ drawCell me (PC elem px py) =
+ let x := cast px * wcell
+ y := cast py * hcell
+ txtX := x + half * wcell
+ txtY := y + half * hcell
+ hovCol := if me == Just elem then s.hoverBG else s.defaultBG
+ in g [transform (Scale (wcellRel / wcell) (hcellRel / hcell))]
+ [ rect [A.x x.u, A.y y.u, width wcell.u, height hcell.u, fill hovCol, stroke black]
+ , text1 [A.x txtX.u, A.y txtY.u, fill (s.elemColor elem)] (show elem)
+ ]
+
+ export
+ displayPSE : Maybe Elem -> SVGNode
+ displayPSE me =
+ g
+ [ fontFamily s.core.font
+ , fontSize (cast s.pseFontSize).px
+ , textAnchor Middle
+ , dominantBaseline Central
+ ]
+ (map (drawCell me) cells)
diff --git a/src/CyBy/Draw/Residue.idr b/src/CyBy/Draw/Residue.idr
new file mode 100644
index 0000000..f0d00f8
--- /dev/null
+++ b/src/CyBy/Draw/Residue.idr
@@ -0,0 +1,74 @@
+||| Corresponds to residues found in `ChemDoodle.RESIDUE`
+module CyBy.Draw.Residue
+
+%default total
+
+
+||| I did not incluede 'acidity', because we don't need it later.
+||| (claudio-etterli)
+record Info where
+ constructor MkInfo
+ symbol : String
+ name : String
+ polar : Bool
+ aminoColor : String
+ shaplyColor : String
+
+
+||| '*' problematic as a type, therefore I named it 'Other'
+data Residue = Ala | Arg | Asn | Asp | Cys | Gln | Glu | Gly | His | Ile |
+ Leu | Lys | Met | Phe | Pro | Ser | Thr | Trp | Tyr | Val |
+ Asx | Glx | A | G | I | C | T | U | Other
+
+public export
+residue : Residue -> Info
+residue Ala = MkInfo "Ala" "Alanine" False "#C8C8C8" "#8CFF8C"
+residue Arg = MkInfo "Arg" "Arginine" True "#145AFF" "#00007C"
+residue Asn = MkInfo "Asn" "Asparagine" True "#00DCDC" "#FF7C70"
+residue Asp = MkInfo "Asp" "Aspartic Acid" True "#E60A0A" "#A00042"
+residue Cys = MkInfo "Cys" "Cysteine" True "#E6E600" "#FFFF70"
+residue Gln = MkInfo "Gln" "Glutamine" True "#00DCDC" "#FF4C4C"
+residue Glu = MkInfo "Glu" "Glutamic Acid" True "#E60A0A" "#660000"
+residue Gly = MkInfo "Gly" "Glycine" False "#EBEBEB" "#FFFFFF"
+residue His = MkInfo "His" "Histidine" True "#8282D2" "#7070FF"
+residue Ile = MkInfo "Ile" "Isoleucine" False "#0F820F" "#004C00"
+residue Leu = MkInfo "Leu" "Leucine" False "#0F820F" "#455E45"
+residue Lys = MkInfo "Lys" "Lysine" True "#145AFF" "#4747B8"
+residue Met = MkInfo "Met" "Methionine" False "#E6E600" "#B8A042"
+residue Phe = MkInfo "Phe" "Phenylalanine" False "#3232AA" "#534C52"
+residue Pro = MkInfo "Pro" "Proline" False "#DC9682" "#525252"
+residue Ser = MkInfo "Ser" "Serine" True "#FA9600" "#FF7042"
+residue Thr = MkInfo "Thr" "Threonine" True "#FA9600" "#B84C00"
+residue Trp = MkInfo "Trp" "Tryptophan" True "#B45AB4" "#4F4600"
+residue Tyr = MkInfo "Tyr" "Tyrosine" True "#3232AA" "#8C704C"
+residue Val = MkInfo "Val" "Valine" False "#0F820F" "#FF8CFF"
+residue Asx = MkInfo "Asx" "Asparagine/Aspartic Acid" True "#FF69B4" "#FF00FF"
+residue Glx = MkInfo "Glx" "Glutamine/Glutamic Acid" True "#FF69B4" "#FF00FF"
+residue A = MkInfo "A" "Adenine" False "#BEA06E" "#A0A0FF"
+residue G = MkInfo "G" "Guanine" False "#BEA06E" "#FF7070"
+residue I = MkInfo "I" "" False "#BEA06E" "#80FFFF"
+residue C = MkInfo "C" "Cytosine" False "#BEA06E" "#FF8C4B"
+residue T = MkInfo "T" "Thymine" False "#BEA06E" "#A0FFA0"
+residue U = MkInfo "U" "Uracil" False "#BEA06E" "#FF8080"
+residue Other = MkInfo "*" "Other" False "#BEA06E" "#FF00FF"
+
+namespace Res
+ public export %inline
+ symbol : Residue -> String
+ symbol = symbol . residue
+
+ public export %inline
+ name : Residue -> String
+ name = name . residue
+
+ public export %inline
+ polar : Residue -> Bool
+ polar = polar . residue
+
+ public export %inline
+ aminoColor : Residue -> String
+ aminoColor = aminoColor . residue
+
+ public export %inline
+ shaplyColor : Residue -> String
+ shaplyColor = shaplyColor . residue
diff --git a/src/Text/Measure.idr b/src/Text/Measure.idr
new file mode 100644
index 0000000..2f38ac0
--- /dev/null
+++ b/src/Text/Measure.idr
@@ -0,0 +1,97 @@
+||| Measuring the visible bounds of text is incredibly hard
+||| and tons of material have been written about this.
+|||
+||| In this module, we take a pragmatic approach that produces
+||| reasonable results without having to load and parse font files.
+||| The drawback of this: The steps described below have to be repeated
+||| for every new font we'd like to support.
+|||
+||| A detailed introduction to typography and how fonts are specified
+||| can be found [here](https://learn.microsoft.com/en-us/typography/opentype/spec/otff).
+|||
+||| In general, we need to know the height and width of a piece of printed text
+||| to properly align it with the rest of the drawing.
+|||
+||| Text height:
+||| there are different types of "height" when it comes to text, and I won't go
+||| into the details here. Suffice to say that we are interested in vertically aligning
+||| atom labels, charges, implicit hydrogen count and mass numbers in a
+||| way that feels natural. For this, wir are mostly interested in "capHeight" of
+||| a font: The height of capital letters (without descenders). This, together
+||| with the Em-square size can be read from font files.
+|||
+||| Text width:
+||| While computing the height of a piece of text is non-trivial, computing its
+||| width is insane. Every glyph has its own specific width, sometimes depending
+||| on its neighbouring glyphs (see ligatures and kerning). Fortunately, there
+||| is a quite simple method to get good approximations without being overly
+||| complicated. It is described on [stackoverflow](https://stackoverflow.com/questions/16007743/roughly-approximate-the-width-of-a-string-of-text-in-python)
+||| We use Python (because it has support for almost everything) to parse
+||| the true type font file we are interested in and generate a dictionary
+||| of the glyphs and their widths we are interested in. Using this to compute
+||| the width of a piece of text at a given font size is efficient and simple
+||| but not perfectly exact because it ignores kerning. It also requires large
+||| dictionaries if we want to support lots of unicode characters.
+|||
+||| Note: The Python script used to extract the glyph widths can be found in the
+||| `resources` directory.
+module Text.Measure
+
+import Data.SortedMap
+
+%default total
+
+-- based on [stackoverflow](https://stackoverflow.com/questions/16007743/roughly-approximate-the-width-of-a-string-of-text-in-python)
+widths : List (Char,Bits32)
+widths = [('0',278),('1',278),('2',278),('3',278),('4',278),('5',278),('6',278),('7',278),('8',278),('9',278),('a',279),('b',278),('c',250),('d',278),('e',278),('f',140),('g',278),('h',278),('i',111),('j',124),('k',251),('l',111),('m',417),('n',278),('o',278),('p',278),('q',278),('r',167),('s',250),('t',139),('u',278),('v',250),('w',364),('x',250),('y',250),('z',250),('A',334),('B',334),('C',361),('D',361),('E',334),('F',305),('G',389),('H',361),('I',139),('J',250),('K',334),('L',278),('M',417),('N',361),('O',389),('P',334),('Q',389),('R',361),('S',334),('T',305),('U',361),('V',334),('W',472),('X',334),('Y',334),('Z',305),('!',139),('"',177),('#',278),('$',278),('%',445),('&',334),('\'',95),('(',167),(')',167),('*',195),('+',292),(',',139),('-',167),('.',139),('/',139),(':',139),(';',139),('<',292),('=',292),('>',292),('?',278),('@',508),('[',139),('\\',139),(']',139),('^',235),('_',292),('`',167),('{',167),('|',130),('}',167),('~',292),(' ',139)]
+
+widthMap : SortedMap Char Bits32
+widthMap = fromList widths
+
+averageWidth : Bits32
+averageWidth = sum widthMap `div` cast (length widths)
+
+charWidth : Bits32 -> Char -> Bits32
+charWidth n c = maybe (n + averageWidth) (n+) $ lookup c widthMap
+
+-- text was measure at a font size of 500, so we divide by that
+-- when computing the width at a different font size.
+textWidth : Nat -> String -> Double
+textWidth fs s = cast (foldl charWidth 0 (unpack s)) * (cast fs) / 500.0
+
+||| Metrics of a piece of text.
+public export
+record TextDims where
+ constructor TD
+ lineHeight : Double
+ capHeight : Double
+ txtWidth : Double
+
+||| Utility for measuring text metrics.
+public export
+record Measure where
+ [noHints]
+ constructor M
+ measure : Nat -> (font, txt : String) -> TextDims
+
+||| This is a primitive but efficient implementation of `Measure`, which
+||| is described in the module docs. A more exact implementation could
+||| make use of a browser canvas and use text metrics from the DOM, but
+||| this is not available when we are not drawing molecules in the browser.
+|||
+||| This implementation assumes a typical roman font similar to Arial.
+||| It is based on the metrics of "Liberation Sans", which should have the
+||| same layout as Arial or Helvetica.
+|||
+||| About magic numbers: 2048 is the Em square size, 1409 the cap height,
+||| 307 the line height. These have to be multiplied with the font size.
+||| Text widths are approxiamted by summing up glyph width stored in a
+||| dictionary.
+export
+defaultMeasure : Measure
+defaultMeasure =
+ M $ \fs,f,s => case length s of
+ 0 => TD 0 0 0
+ n =>
+ let fsd := cast {to = Double} fs
+ in TD (fsd * 307.0 / 2048.0) (fsd * 1409.0 / 2048.0) (textWidth fs s)