0 | module CyBy.Draw.Internal.Label

  2 | import CyBy.Draw.Internal.Atom

  3 | import CyBy.Draw.Internal.CoreDims

  4 | import CyBy.Draw.Internal.Graph

  5 | import Data.Finite

  6 | import Geom

  7 | import Text.Measure

  8 | import Text.Molfile

 10 | %default total

 13 | bgRadiusFactor : Double

 14 | bgRadiusFactor = 0.7 -- 0.5 * sqrt 2 

 16 | export %inline

 17 | lineEndRadius : Double

 18 | lineEndRadius = 0.5

 27 | public export

 28 | data HPos = NoH | N | W | S | E

 36 | public export

 37 | record Text a where

 38 |   constructor T

 39 |   fsize   : Nat

 40 |   text    : String

 41 |   pos     : a      -- Position (center) of the text label

 42 |   dims    : TextDims

 45 | (.h) : Text a -> Double

 46 | t.h = t.dims.capHeight

 49 | (.lh) : Text a -> Double

 50 | t.lh = t.dims.lineHeight

 53 | (.w) : Text a -> Double

 54 | t.w = t.dims.txtWidth

 56 | public export

 57 | Geom.Bounds.Bounded (Text $ Point Id) where

 58 |   btrans = Id

 59 |   bounds (T _ "" _ _) = neutral

 60 |   bounds (T _ _ (P x y) (TD _ cs w)) =

 61 |     BS (range (x-w/2) (x+w/2)) (range (y-cs/2) (y+cs/2))

 65 | noLbl : Text ()

 66 | noLbl = T 0 "" () (TD 0 0 0)

 70 | text : (cd : CoreDims) => (sub : Bool) -> (text : String) -> Text ()

 71 | text _   "" = noLbl

 72 | text sub s  =

 73 |   let fs := if sub then cd.subscriptSize else cd.fontSize

 74 |    in T fs s () $ cd.measure.measure fs cd.font s

 78 | radius : Text a -> Maybe Double

 79 | radius (T _ "" _ _)           = Nothing

 80 | radius (T _ _  _ $ TD _ cs w) = Just $ max cs w * bgRadiusFactor

 82 | trans : Vector Id -> Double -> Maybe Double -> Point Id -> Point Id

 83 | trans v l Nothing  x = x

 84 | trans v l (Just r) x = translate (scale (r / l) v) x

 89 | adjEndPoints :

 90 |      (x,y : Point Id)

 91 |   -> (rx,ry : Maybe Double)

 92 |   -> Maybe (Point Id, Point Id)

 93 | adjEndPoints x y rx ry =

 94 |   let v    := x - y

 95 |       lv   := length v

 96 |       True := lv > fromMaybe 0 rx + fromMaybe 0 ry | False => Nothing

 97 |    in Just (trans (negate v) lv rx x, trans v lv ry y)

102 | (.textPos) : Text (Point Id) -> Point Id

103 | l.textPos =

104 |   let P x y := l.pos

105 |    in P x (y + l.dims.capHeight / 2.0)

109 | public export

110 | record AtomLabels a where

111 |   constructor AL

112 |   symbol   : Text a

113 |   charge   : Text a

114 |   mass     : Text a

115 |   hydrogen : Text a

116 |   hcount   : Text a

119 | labels : AtomLabels a -> List (Text a)

120 | labels (AL v w x y z) = [v,w,x,y,z]

122 | public export

123 | Geom.Bounds.Bounded (AtomLabels $ Point Id) where

124 |   btrans = Id

125 |   bounds = foldMap bounds . labels

128 | chargeLabel : Charge -> String

129 | chargeLabel 0    = ""

130 | chargeLabel 1    = "+"

131 | chargeLabel (-1) = "-"

132 | chargeLabel n    =

133 |   if n > 0 then "\{show n.value}+" else "\{show $ abs n.value}-"

136 | massLabel : Maybe MassNr -> String

137 | massLabel = maybe "" (show . value)

140 | hlabel : HCount -> String

141 | hlabel 0 = ""

142 | hlabel _ = "H"

145 | hsubscript : HCount -> String

146 | hsubscript h = if h > 1 then show h.value else ""

153 | setPositions : HPos -> Point Id -> AtomLabels () -> AtomLabels (Point Id)

154 | setPositions x p (AL s c m h hc) =

155 |   let -- displacement of the "H" label (if any)

156 |       vh  := case x of

157 |                N => case c.h > 0.0 && hc.h > 0.0 of

158 |                  True  => vid 0 (negate $ s.h + (c.h + hc.h) / 2.0)

159 |                  False => vid 0 (negate $ s.h + s.lh)

160 |                -- put H below atom label

161 |                S => vid 0 (h.h + h.lh)

163 |                -- put H left of atom label making space for hydrogen count

164 |                -- and mass number

165 |                W => vid (negate $ (s.w + h.w) / 2 + max hc.w m.w) 0

167 |                -- put H to the right of atom label

168 |                -- charge will come after H label.

169 |                _ => vid ((s.w + h.w) / 2) 0

171 |       -- displacement of the mass number label (if any)

172 |       vm  := vid (negate $ (s.w + m.w) / 2) (m.h / 2 - s.h)

174 |       -- displacement of the charge label (if any)

175 |       vc  := case x of

176 |                E => vid ((s.w + c.w) / 2 + h.w) (c.h / 2 - s.h)

177 |                _ => vid ((s.w + c.w) / 2) (c.h / 2 - s.h)

179 |       -- displacement of the H-count label (in case of more than 1 impl. H)

180 |       vhc := vid ((h.w + hc.w) / 2) (h.h / 2.0)

182 |       -- Text (Point Id) for the atom symbol

183 |       sym := {pos := p} s

185 |       -- Text (Point Id) for the "H" label

186 |       -- We must make sure this is at same textual height as the atom

187 |       -- symbol if we place it left or right of the atom symbol

188 |       hyd := {pos := translate vh p} h

190 |    in AL

191 |         { symbol   = sym

192 |         , charge   = {pos := translate vc p} c

193 |         , mass     = {pos := translate vm p} m

194 |         , hydrogen = hyd

195 |         , hcount   = {pos := translate vhc hyd.pos} hc

196 |         }

202 | public export

203 | data AbbrPos = AE | AW

206 | abbrTextPos : CoreDims => AbbrPos -> Point Id -> Text () -> Text (Point Id)

207 | abbrTextPos @{cd} AE (P x y) t =

208 |   case t.w < 2*cd.radiusAtom of

209 |     True  => {pos := P x y} t

210 |     False => {pos := P (x + t.w / 2.0 - cd.radiusAtom) y} t

211 | abbrTextPos @{cd} AW (P x y) t =

212 |   case t.w < 2*cd.radiusAtom of

213 |     True  => {pos := P x y} t

214 |     False => {pos := P (x - t.w / 2.0 + cd.radiusAtom) y} t

220 | firstAfter : Eq a => a -> List a -> a

221 | firstAfter v vs =

222 |   case break (v ==) vs of

223 |     (_, _::x::_) => x

224 |     (x::_, [_])  => x

225 |     (x::_, [])   => x

226 |     (_, _)       => v

228 | getListElems : String -> List Elem

229 | getListElems s = filter (isPrefixOf s . show) values

238 | updateElem : String -> Elem -> Elem

239 | updateElem s e = firstAfter e $ sortBy (comparing show) (getListElems s)

243 | updateIsotope : String -> Isotope -> Isotope

244 | updateIsotope s i = cast $ updateElem s i.elem

247 | masses : Elem -> List (Maybe MassNr)

248 | masses e = Nothing :: sort (map (Just . massNr) $ isotopes e)

250 | isoList : Elem -> List Isotope

251 | isoList el = MkI el <$> masses el

254 | incIso : Isotope -> Isotope

255 | incIso i = firstAfter i (isoList i.elem)

258 | decIso : Isotope -> Isotope

259 | decIso i = firstAfter i (reverse $ isoList i.elem)

265 | public export

266 | data Label : Type where

267 |   Hidden       : Label

268 |   NoLabel      : Point Id -> Label

269 |   Abbreviation : Point Id -> Text (Point Id) -> Label

270 |   Explicit     : AtomLabels (Point Id) -> Label

272 | public export

273 | 0 Labels : Nat -> Type

274 | Labels k = IArray k Label

276 | circleBounds : (cd : CoreDims) => Point Id -> Bounds2D Id

277 | circleBounds (P x y) =

278 |   let r := cd.radiusAtom in BS (range (x-r) (x+r)) (range (y-r)(y+r))

280 | public export

281 | (cd : CoreDims) => Geom.Bounds.Bounded Label where

282 |   btrans = Id

283 |   bounds Hidden             = neutral

284 |   bounds (NoLabel p)        = circleBounds p

285 |   bounds (Explicit x)       = bounds x

286 |   bounds (Abbreviation _ x) = bounds x

296 | trimToCircle :

297 |      Point t

298 |   -> Vector (transform t)

299 |   -> (c : Point t)

300 |   -> (r : Double)

301 |   -> Double

302 | trimToCircle (P x y) (V vx vy) (P cx cy) r =

303 |   let dx   := x - cx

304 |       dy   := y - cy

305 |    in case solveQuadratic (vx*vx+vy*vy) (2*(dx*vx+dy*vy)) (dx*dx+dy*dy-r*r) of

306 |         Nothing      => 1.0

307 |         Just (s1,s2) => if s1 < 0 then if s2 >= 0 then 0 else 1 else min s1 1

309 | textFactor : Point Id -> Vector Id -> Text (Point Id) -> Double

310 | textFactor p v t =

311 |   case radius t of

312 |     Nothing => 1

313 |     Just r  => trimToCircle p v t.pos (r + lineEndRadius)

315 | abbrFactor : CoreDims => Point Id -> Vector Id -> Point Id -> Double

316 | abbrFactor @{cd} p v q = trimToCircle p v q (cd.radiusAtom + 4 * lineEndRadius)

318 | factor : CoreDims => Point Id -> Vector Id -> Label -> Double

319 | factor p v Hidden             = 0

320 | factor p v (NoLabel _)        = 1

321 | factor p v (Abbreviation q _) = abbrFactor p v q

322 | factor p v (Explicit ls)      = foldl min 1 (textFactor p v <$> labels ls)

327 | endpoints :

328 |      {auto _: CoreDims}

329 |   -> (x,y : Point Id)

330 |   -> (lx,ly : Label)

331 |   -> Maybe (Point Id, Point Id)

332 | endpoints x y (NoLabel _) (NoLabel _) = Just (x,y)

333 | endpoints x y Hidden      _           = Nothing

334 | endpoints x y _           Hidden      = Nothing

335 | endpoints x y lx          ly          =

336 |   let vx := y - x

337 |       vy := x - y

338 |       fx := factor x vx ly

339 |       fy := factor y vy lx

340 |    in if fx + fy <= 1

341 |          then Nothing

342 |          else Just ( translate (scale (1-fy) vx) x

343 |                    , translate (scale (1-fx) vy) y

344 |                    )

353 | abbrPos : CDIGraph k -> Fin k -> AbbrPos

354 | abbrPos g x =

355 |   let [a] := bondAngles g x | _ => AE

356 |    in if a <= halfPi || a >= (negate halfPi) then AW else AE

361 | bestHPos : List Geom.Angle.Angle -> HPos

362 | bestHPos xs =

363 |   if      all (\x => x >= halfPi && x <= threeHalfPi) xs then E

364 |   else if all (\x => x <= halfPi || x >= threeHalfPi) xs then W

365 |   else if all (\x => x < angle (5 * pi / 4) || x > angle (7 * pi / 4)) xs

366 |                      -- in case several bonds point slightly north -> position H

367 |                      -- on the south side (or east)

368 |                      && count (> pi) xs < 2 then N

369 |   else if all (\x => x > angle (3 * pi / 4) || x < angle (pi / 4)) xs then S

370 |   else E -- catch-all pattern for very crowded atoms

377 | hpos : CDIGraph k -> Fin k -> HPos

378 | hpos g x =

379 |   case Atom.hydrogen . atom $ lab g x of

380 |     0 => NoH

381 |     _ => bestHPos (bondAngles g x)