bjogui/src/draw.bjo

;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.

;; bjogui/src/draw.bjo — the module (bjogui draw).
;;
;; Drawing with a pen: what a component made by `component` in (bjogui view)
;; draws itself with. Each function draws at once, on top of what is drawn
;; before it, in the component's own coordinates: 0, 0 is its top left
;; corner, x grows to the right and y down, in pixels.
;;
;; A colour is a string, as everywhere in bjogui: a name such as "red", or
;; "#rgb", "#rrggbb" or "#aarrggbb". The empty string, and a colour that
;; cannot be read, draw nothing. An angle is in radians, as `sin` and `cos`
;; of (std maths) take it, and grows clockwise from the right, because y
;; grows down.
;;
;; The pen is Avalonia's DrawingContext, so a drawing is vectors: it is sharp
;; at any scale of the screen.

(export
  Pen
  ;; Shapes.
  fill-rect stroke-rect fill-circle stroke-circle fill-ellipse stroke-ellipse
  stroke-line stroke-polyline fill-polygon stroke-arc fill-path stroke-path
  ;; Text and pictures.
  draw-text text-size draw-image
  ;; What is drawn inside a function, moved, turned, cut or faded.
  translated scaled rotated clipped faded
  ;; For (bjogui app): a drawing, as the picture an Image shows.
  drawing-image)

(import (std prelude))
(import (std maths))
(import (std interop))
(import (std mutable map))

(import/class
  (Object         (: System.Object))
  (Disposable     (: System.IDisposable))
  (Culture        (: System.Globalization.CultureInfo))
  (IBrush         (: Avalonia.Media.IBrush))
  (IPen           (: Avalonia.Media.IPen))
  (AvPen          (: Avalonia.Media.Pen (-> IBrush double IDashStyle LineCap LineJoin double AvPen)))
  (IDashStyle     (: Avalonia.Media.IDashStyle))
  (DashStyle      (: Avalonia.Media.DashStyle (-> (Seq double) double DashStyle)))
  (LineCap        (: Avalonia.Media.PenLineCap))
  (LineJoin       (: Avalonia.Media.PenLineJoin))
  (BoxShadows     (: Avalonia.Media.BoxShadows))
  (Rect           (: Avalonia.Rect (-> double double double double Rect)))
  (Point          (: Avalonia.Point (-> double double Point)))
  (Size           (: Avalonia.Size (-> double double Size)))
  (Matrix         (: Avalonia.Matrix))
  (Geometry       (: Avalonia.Media.Geometry))
  (RectGeometry   (: Avalonia.Media.RectangleGeometry (-> Rect double double RectGeometry)))
  (StreamGeometry (: Avalonia.Media.StreamGeometry (-> StreamGeometry)))
  (GeometryContext (: Avalonia.Media.StreamGeometryContext))
  (Sweep          (: Avalonia.Media.SweepDirection))
  (DrawingGroup   (: Avalonia.Media.DrawingGroup (-> DrawingGroup)))
  (DrawingImage   (: Avalonia.Media.DrawingImage (-> Drawing DrawingImage)))
  (Drawing        (: Avalonia.Media.Drawing))
  (DrawingContext (: Avalonia.Media.DrawingContext))
  (PushedState    (: Avalonia.Media.DrawingContext.PushedState))
  (IImage         (: Avalonia.Media.IImage))
  (Bitmap         (: Avalonia.Media.Imaging.Bitmap (-> string Bitmap)))
  (FontFamily     (: Avalonia.Media.FontFamily (-> string FontFamily)))
  (FontStyle      (: Avalonia.Media.FontStyle))
  (FontWeight     (: Avalonia.Media.FontWeight))
  (FontStretch    (: Avalonia.Media.FontStretch))
  (Typeface       (: Avalonia.Media.Typeface (-> FontFamily FontStyle FontWeight FontStretch Typeface)))
  (FlowDirection  (: Avalonia.Media.FlowDirection))
  (FormattedText  (: Avalonia.Media.FormattedText
                     (-> string Culture FlowDirection Typeface double IBrush FormattedText))))

(import/extern
  (parse-brush    (: Avalonia.Media.Brush.Parse (-> string IBrush)))
  (parse-geometry (: Avalonia.Media.Geometry.Parse (-> string Geometry)))
  (open-group     (: Avalonia.Media.DrawingGroup.Open (-> DrawingGroup DrawingContext)))
  (bounds-of      (: Avalonia.Media.Drawing.GetBounds (-> Drawing Rect)))
  (rect-x         (: Avalonia.Rect.X (-> Rect double) #:get))
  (rect-y         (: Avalonia.Rect.Y (-> Rect double) #:get))
  (open-geometry  (: Avalonia.Media.StreamGeometry.Open (-> StreamGeometry GeometryContext)))
  (begin-figure!  (: Avalonia.Media.StreamGeometryContext.BeginFigure (-> GeometryContext Point bool void)))
  (line-to!       (: Avalonia.Media.StreamGeometryContext.LineTo (-> GeometryContext Point void)))
  (arc-to!        (: Avalonia.Media.StreamGeometryContext.ArcTo
                     (-> GeometryContext Point Size double bool Sweep void)))
  (end-figure!    (: Avalonia.Media.StreamGeometryContext.EndFigure (-> GeometryContext bool void)))
  (dc-rect        (: Avalonia.Media.DrawingContext.DrawRectangle
                     (-> DrawingContext IBrush IPen Rect double double BoxShadows void)))
  (dc-ellipse     (: Avalonia.Media.DrawingContext.DrawEllipse
                     (-> DrawingContext IBrush IPen Point double double void)))
  (dc-line        (: Avalonia.Media.DrawingContext.DrawLine (-> DrawingContext IPen Point Point void)))
  (dc-geometry    (: Avalonia.Media.DrawingContext.DrawGeometry
                     (-> DrawingContext IBrush IPen Geometry void)))
  (dc-text        (: Avalonia.Media.DrawingContext.DrawText (-> DrawingContext FormattedText Point void)))
  (dc-image       (: Avalonia.Media.DrawingContext.DrawImage (-> DrawingContext IImage Rect void)))
  (push-transform (: Avalonia.Media.DrawingContext.PushTransform (-> DrawingContext Matrix PushedState)))
  (push-clip      (: Avalonia.Media.DrawingContext.PushClip (-> DrawingContext Rect PushedState)))
  (push-opacity   (: Avalonia.Media.DrawingContext.PushOpacity (-> DrawingContext double PushedState)))
  (pop!           (: Avalonia.Media.DrawingContext.PushedState.Dispose (-> PushedState void)))
  (translation    (: Avalonia.Matrix.CreateTranslation (-> double double Matrix)))
  (scaling        (: Avalonia.Matrix.CreateScale (-> double double Matrix)))
  (rotation       (: Avalonia.Matrix.CreateRotation (-> double Point Matrix)))
  (text-width     (: Avalonia.Media.FormattedText.Width (-> FormattedText double) #:get))
  (text-height    (: Avalonia.Media.FormattedText.Height (-> FormattedText double) #:get))
  (max-text-width! (: Avalonia.Media.FormattedText.MaxTextWidth (-> FormattedText double void) #:set))
  (default-family (: Avalonia.Media.FontFamily.Default #:get))
  (invariant      (: System.Globalization.CultureInfo.InvariantCulture #:get))
  (dispose!       (: System.IDisposable.Dispose (-> Disposable void))))

;; ---------------------------------------------------------------------------
;; The pen
;; ---------------------------------------------------------------------------

;; What a component draws with, for as long as its `#:draw` function runs.
(type (: Pen #:opaque (Record (: dc DrawingContext))))

;; ---------------------------------------------------------------------------
;; What is read once
;; ---------------------------------------------------------------------------

;; Colours, paths, pictures and fonts are read once each and kept, because a
;; component draws them again on each change. A table that grows past its
;; limit is emptied, so a program that makes new paths all the time does not
;; keep them all.
(def cache-limit 2000)

(: brushes (MutableMap string (Option IBrush)))
(def brushes (mutablemap))

(: geometries (MutableMap string (Option Geometry)))
(def geometries (mutablemap))

(: bitmaps (MutableMap string (Option Bitmap)))
(def bitmaps (mutablemap))

(: typefaces (MutableMap string Typeface))
(def typefaces (mutablemap))

(: (-> (MutableMap string %a) string (-> %a) %a))
(defun (cached table key make)
  (match (mutablemap-try-ref table key)
    ((Some v) v)
    (None
     (when (>= (mutablemap-length table) cache-limit) (mutablemap-clear! table))
     (def v (make))
     (mutablemap-set! table key v)
     v)))

(: (-> string (Option IBrush)))
(defun (brush colour)
  (if (string-empty? colour)
      None
      (cached brushes colour
              (fun ()
                (match (try (parse-brush colour) #:catch (System.Exception))
                  ((Ok b) (Some b))
                  ((Err _) None))))))

(: (-> string (Option Geometry)))
(defun (geometry data)
  (cached geometries data
          (fun ()
            (match (try (parse-geometry data) #:catch (System.Exception))
              ((Ok g) (Some g))
              ((Err _) None)))))

(: (-> string (Option Bitmap)))
(defun (bitmap path)
  (cached bitmaps path
          (fun ()
            (match (try (Bitmap. path) #:catch (System.Exception))
              ((Ok b) (Some b))
              ((Err _) None)))))

(: (-> string bool Typeface))
(defun (typeface font bold?)
  (cached typefaces #"${font}/${bold?}"
          (fun ()
            (Typeface. (if (string-empty? font) default-family (FontFamily. font))
                       FontStyle.Normal (if bold? FontWeight.Bold FontWeight.Normal) FontStretch.Normal))))

;; A line of `width`, in the brush. `cap` is "flat", "round" or "square".
;; `dash` is the lengths of the dashes and the gaps between them, in widths
;; of the line, in turn; empty for a solid line.
(: (-> IBrush double string (Vec double) IPen))
(defun (line-pen b width cap dash)
  (def c (match cap ("round" LineCap.Round) ("square" LineCap.Square) (_ LineCap.Flat)))
  (def d (if (vec-empty? dash)
             (: (clr-default) IDashStyle)
             (cast IDashStyle (DashStyle. (cast (Seq double) (: (vec->array dash) (Array double))) 0.0))))
  (cast IPen (AvPen. b width d c LineJoin.Round 10.0)))

(: (-> double double Point))
(defun (pt x y) (Point. x y))

(def no-brush (: (clr-default) IBrush))
(def no-pen (: (clr-default) IPen))

;; ---------------------------------------------------------------------------
;; Shapes
;; ---------------------------------------------------------------------------

;; The rectangle at `x`, `y`, `w` by `h`, filled, with corners as round as
;; `#:radius`.
;; A rectangle with round corners is drawn as a geometry, because a drawing
;; that is kept, as a component's is, drops the corners of DrawRectangle.
(: (-> Pen IBrush IPen double double double double double void))
(defun (rect! pen b p x y w h radius)
  (if (> radius 0.0)
      (dc-geometry (.dc pen) b p (cast Geometry (RectGeometry. (Rect. x y w h) radius radius)))
      (dc-rect (.dc pen) b p (Rect. x y w h) 0.0 0.0 (clr-default))))

(: fill-rect (-> Pen double double double double string (#:radius double) void))
(defun (fill-rect pen x y w h colour #:radius 0.0)
  (match (brush colour)
    ((Some b) (rect! pen b no-pen x y w h radius))
    (None unit)))

;; The line around a rectangle. The line is centred on the rectangle's edge.
(: stroke-rect (-> Pen double double double double string (#:width double) (#:radius double)
                   (#:dash (Vec double))
                   void))
(defun (stroke-rect pen x y w h colour #:width 1.0 #:radius 0.0 #:dash [])
  (match (brush colour)
    ((Some b) (rect! pen no-brush (line-pen b width "flat" dash) x y w h radius))
    (None unit)))

;; The circle around `cx`, `cy`, of radius `r`, filled.
(: fill-circle (-> Pen double double double string void))
(defun (fill-circle pen cx cy r colour)
  (fill-ellipse pen (- cx r) (- cy r) (* 2.0 r) (* 2.0 r) colour))

;; The line around a circle.
(: stroke-circle (-> Pen double double double string (#:width double) (#:dash (Vec double)) void))
(defun (stroke-circle pen cx cy r colour #:width 1.0 #:dash [])
  (stroke-ellipse pen (- cx r) (- cy r) (* 2.0 r) (* 2.0 r) colour #:width width #:dash dash))

;; The ellipse in the rectangle at `x`, `y`, `w` by `h`, filled.
(: fill-ellipse (-> Pen double double double double string void))
(defun (fill-ellipse pen x y w h colour)
  (match (brush colour)
    ((Some b) (dc-ellipse (.dc pen) b no-pen (pt (+ x (/ w 2.0)) (+ y (/ h 2.0))) (/ w 2.0) (/ h 2.0)))
    (None unit)))

;; The line around an ellipse.
(: stroke-ellipse (-> Pen double double double double string (#:width double) (#:dash (Vec double))
                      void))
(defun (stroke-ellipse pen x y w h colour #:width 1.0 #:dash [])
  (match (brush colour)
    ((Some b) (dc-ellipse (.dc pen) no-brush (line-pen b width "flat" dash)
                          (pt (+ x (/ w 2.0)) (+ y (/ h 2.0))) (/ w 2.0) (/ h 2.0)))
    (None unit)))

;; A line from `x1`, `y1` to `x2`, `y2`. `#:cap` is how its ends look:
;; "flat", "round" or "square".
(: stroke-line (-> Pen double double double double string (#:width double) (#:cap string)
                   (#:dash (Vec double))
                   void))
(defun (stroke-line pen x1 y1 x2 y2 colour #:width 1.0 #:cap "flat" #:dash [])
  (match (brush colour)
    ((Some b) (dc-line (.dc pen) (line-pen b width cap dash) (pt x1 y1) (pt x2 y2)))
    (None unit)))

;; The geometry through `points`, closed when `closed?`.
(: (-> (Vec (Tuple double double)) bool bool (Option Geometry)))
(defun (through points filled? closed?)
  (if (< (vec-length points) 2)
      None
      (begin
        (def g (StreamGeometry.))
        (def ctx (open-geometry g))
        (def (Tuple x0 y0) (vec-ref points 0))
        (begin-figure! ctx (pt x0 y0) filled?)
        (loop (:for (Tuple x y) (vec-drop points 1)) (:do (line-to! ctx (pt x y))))
        (end-figure! ctx closed?)
        (dispose! (cast Disposable ctx))
        (Some (cast Geometry g)))))

;; Lines from each of `points` to the next.
(: stroke-polyline (-> Pen (Vec (Tuple double double)) string (#:width double) (#:cap string)
                       (#:dash (Vec double))
                       void))
(defun (stroke-polyline pen points colour #:width 1.0 #:cap "flat" #:dash [])
  (match (Tuple (brush colour) (through points #f #f))
    ((Tuple (Some b) (Some g)) (dc-geometry (.dc pen) no-brush (line-pen b width cap dash) g))
    (_ unit)))

;; The polygon with `points` at its corners, filled.
(: fill-polygon (-> Pen (Vec (Tuple double double)) string void))
(defun (fill-polygon pen points colour)
  (match (Tuple (brush colour) (through points #t #t))
    ((Tuple (Some b) (Some g)) (dc-geometry (.dc pen) b no-pen g))
    (_ unit)))

;; A piece of the circle around `cx`, `cy` of radius `r`: from the angle
;; `from`, `sweep` radians on, clockwise when `sweep` is more than 0. A sweep
;; of a whole turn or more is the whole circle.
(: stroke-arc (-> Pen double double double double double string (#:width double) (#:cap string)
                  (#:dash (Vec double))
                  void))
(defun (stroke-arc pen cx cy r from sweep colour #:width 1.0 #:cap "flat" #:dash [])
  (def turn (* 2.0 3.141592653589793))
  (defun (at a) (pt (+ cx (* r (cos a))) (+ cy (* r (sin a)))))
  (match (brush colour)
    ((Some b)
     (cond ((>= (abs sweep) (- turn 1e-9))
            (stroke-circle pen cx cy r colour #:width width #:dash dash))
           ((= sweep 0.0) unit)
           (else
            (def g (StreamGeometry.))
            (def ctx (open-geometry g))
            (begin-figure! ctx (at from) #f)
            (arc-to! ctx (at (+ from sweep)) (Size. r r) 0.0 (> (abs sweep) (/ turn 2.0))
                     (if (> sweep 0.0) Sweep.Clockwise Sweep.CounterClockwise))
            (end-figure! ctx #f)
            (dispose! (cast Disposable ctx))
            (dc-geometry (.dc pen) no-brush (line-pen b width cap dash) (cast Geometry g)))))
    (None unit)))

;; The path `data`, written as SVG writes one: "M 10 10 L 50 10 L 30 40 Z"
;; is a triangle. Filled. A path that cannot be read draws nothing.
(: fill-path (-> Pen string string void))
(defun (fill-path pen data colour)
  (match (Tuple (brush colour) (geometry data))
    ((Tuple (Some b) (Some g)) (dc-geometry (.dc pen) b no-pen g))
    (_ unit)))

;; The line along the path `data`.
(: stroke-path (-> Pen string string (#:width double) (#:cap string) (#:dash (Vec double)) void))
(defun (stroke-path pen data colour #:width 1.0 #:cap "flat" #:dash [])
  (match (Tuple (brush colour) (geometry data))
    ((Tuple (Some b) (Some g)) (dc-geometry (.dc pen) no-brush (line-pen b width cap dash) g))
    (_ unit)))

;; ---------------------------------------------------------------------------
;; Text and pictures
;; ---------------------------------------------------------------------------

(: (-> string IBrush double bool string double FormattedText))
(defun (formatted s b size bold? font max-width)
  (def t (FormattedText. s invariant FlowDirection.LeftToRight (typeface font bold?) size b))
  (when (> max-width 0.0) (max-text-width! t max-width))
  t)

;; The text `s` with its top at `y`. `#:align` says where `x` is on it:
;; "left", "centre" or "right". `#:font` is the name of a font, "" for the
;; theme's. With `#:max-width`, the text breaks its lines at that width.
(: draw-text (-> Pen string double double string (#:size double) (#:bold bool) (#:font string)
                 (#:align string) (#:max-width double)
                 void))
(defun (draw-text pen s x y colour #:size 14.0 #:bold #f #:font "" #:align "left" #:max-width 0.0)
  (match (brush colour)
    ((Some b)
     (def t (formatted s b size bold font max-width))
     (def left (match align
                 ("centre" (- x (/ (text-width t) 2.0)))
                 ("right" (- x (text-width t)))
                 (_ x)))
     (dc-text (.dc pen) t (pt left y)))
    (None unit)))

;; The width and the height that `draw-text` gives `s`, with the same
;; options. For a component to lay out its text.
(: text-size (-> string (#:size double) (#:bold bool) (#:font string) (#:max-width double)
                 (Tuple double double)))
(defun (text-size s #:size 14.0 #:bold #f #:font "" #:max-width 0.0)
  (def t (formatted s (parse-brush "black") size bold font max-width))
  (Tuple (text-width t) (text-height t)))

;; The picture in the file at `path`, in the rectangle at `x`, `y`, `w` by
;; `h`. A file that cannot be read draws nothing.
(: draw-image (-> Pen string double double double double void))
(defun (draw-image pen path x y w h)
  (match (bitmap path)
    ((Some b) (dc-image (.dc pen) (cast IImage b) (Rect. x y w h)))
    (None unit)))

;; ---------------------------------------------------------------------------
;; Moved, turned, cut and faded
;; ---------------------------------------------------------------------------

(: (-> PushedState (-> void) void))
(defun (inside state body)
  (body)
  (pop! state))

;; What `body` draws, moved by `dx`, `dy`.
(: translated (-> Pen double double (-> void) void))
(defun (translated pen dx dy body)
  (inside (push-transform (.dc pen) (translation dx dy)) body))

;; What `body` draws, `sx` times as wide and `sy` times as tall, from 0, 0.
(: scaled (-> Pen double double (-> void) void))
(defun (scaled pen sx sy body)
  (inside (push-transform (.dc pen) (scaling sx sy)) body))

;; What `body` draws, turned by `angle` around `cx`, `cy`.
(: rotated (-> Pen double double double (-> void) void))
(defun (rotated pen angle cx cy body)
  (inside (push-transform (.dc pen) (rotation angle (pt cx cy))) body))

;; What `body` draws, only inside the rectangle at `x`, `y`, `w` by `h`.
(: clipped (-> Pen double double double double (-> void) void))
(defun (clipped pen x y w h body)
  (inside (push-clip (.dc pen) (Rect. x y w h)) body))

;; What `body` draws, at `opacity`: 0 is not seen, 1 is as drawn.
(: faded (-> Pen double (-> void) void))
(defun (faded pen opacity body)
  (inside (push-opacity (.dc pen) opacity) body))

;; ---------------------------------------------------------------------------
;; For the app
;; ---------------------------------------------------------------------------

;; What `draw` draws on `w` by `h`, as a picture that an Image shows, and
;; where the Image goes for 0, 0 to be the top left corner. None when there
;; is no room.
;;
;; A DrawingImage moves the top left corner of what is drawn to its own 0, 0,
;; so a drawing that starts at 10, 10, or at -5, 0, would move. The place of
;; the bounds' corner is given back, and the Image is put there, which moves
;; the drawing back. What is drawn is cut to `w` by `h`, so what is outside
;; costs nothing to show.
(: drawing-image (-> (-> Pen void) double double (Option (Tuple Object double double))))
(defun (drawing-image draw w h)
  (if (or (<= w 0.0) (<= h 0.0))
      None
      (begin
        (def group (DrawingGroup.))
        (def dc (open-group group))
        (def pen (Pen (dc dc)))
        (clipped pen 0.0 0.0 w h (fun () (draw pen)))
        (dispose! (cast Disposable dc))
        (def b (bounds-of (cast Drawing group)))
        (Some (Tuple (cast Object (DrawingImage. (cast Drawing group))) (rect-x b) (rect-y b))))))