stefan-hoeck · stefan-hoeck · Aug 22, 2024 · Aug 22, 2024 · Aug 22, 2024 · Aug 22, 2024
diff --git a/.github/linters/.ecrc 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
@@ -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
@@ -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
@@ -0,0 +1,2 @@
+build/
+.DS_Store
diff --git 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
@@ -0,0 +1,13 @@
+<!DOCTYPE html>
+<html>
+ <head>
+  <meta charset='utf-8'>
+  <style id='appstyle'></style>
+  <link rel="stylesheet" type="text/css" href="css/cyby-draw.css">
+ </head>
+ <body id='content'>
+  <div id='app_sketcher_div'></div>
+  <div id='messages'></div>
+  <script type='text/javascript' src='app/build/exec/cyby-draw-app.js'></script>
+ </body>
+</html>
diff --git a/app/cyby-draw-app.ipkg 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
@@ -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
@@ -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
@@ -0,0 +1,6 @@
+module Main
+
+import Html
+
+main : IO ()
+main = app