SATySFi で Tikz ライクなお絵描きを実現する構想

graphics.saty

@require: stdjareport
@require: list
@require: color
@require: base/length
@require: base/tuple
@require: xpath/xpath
@require: xpath/util
@require: xpath-gr/gr
% @require: debug-show-value/debug-show-value

% type declarations
type context = (|
  line-width : length;
  draw-color : color;
  inner-sep : length;
  precision : length; % precision for calculating intersections
|)

type node = Node of (|
  position : point;
  border : context -> point -> XPath.t;
  content: graphics;
  % style: ctx -> ctx
|)

type edge = Edge of (|
  from: node;
  to: node;
  shorten: point * point;
  % style: ctx -> ctx
|)

type picture = (|
  nodes: node list;
  edges: edge list;
  context: context;
|)

% default context
let default-context = (|
  line-width = 1pt;
  draw-color = Color.black;
  inner-sep = 2pt;
  precision = 0.1pt;
|)

let draw ctx path =
  XPath.stroke ctx#line-width ctx#draw-color path

% node
let circle ctx r =
  fun pt -> XPathGr.circle pt r

let make-rectangle-border w h d ctx pt =
  let inner-sep = ctx#inner-sep in
  let shift = (w *' 0.5 +' inner-sep, (h +' d) *' 0.5 +' inner-sep) in
  XPathUtil.(XPathGr.rectangle (pt -.. shift) (pt +.. shift))

let make-text-node text-ctx point it =
  let ib = read-inline text-ctx it in
  let content = draw-text point ib in
  let (w,h,d) = get-natural-metrics ib in
  let gr = shift-graphics ((w *' -0.5), ((h -' d) *' -0.5)) content in
  (|
    position = point;
    border = make-rectangle-border w h d;
    content = gr;
  |)

let node-to-path ctx node =
  node#border ctx node#position

let node-to-graphics ctx node =
  let border = node-to-path ctx node in
  let border-gr = draw ctx border in
  [ node#content; border-gr ]

% edge
let make-edge from to =
  (|
    from = from;
    to = to;
    shorten = (0pt, 0pt);
  |)

let shorten (l1, l2) edge =
  (| edge with shorten = (l1, l2) |)

let cut-at precision point ppat =
  let len = XPath.get-projection-length precision point ppat in
  XPath.split precision len ppat

let cut-at-first-point precision point-list ppat =
  match point-list with
  | [] -> ppat
  | point :: _ -> Pair.fst (cut-at precision point ppat)

let cut-until-last-point precision point-list ppat =
  point-list |> List.fold-left
    (fun ppat point -> Pair.snd (cut-at precision point ppat))
    ppat

let shorten-prepath precision (l1, l2) ppat =
  let l = XPath.get-rough-length precision ppat in
  ppat
  |> XPath.split precision (l -' l2) |> Pair.fst
  |> XPath.split precision l1 |> Pair.snd

let edge-to-path ctx edge =
  let ppat = XPath.start-path edge#from#position
    |> XPath.line-to edge#to#position in
  % TODO: Intersections calculation of Xpath seems wrong. Needs debugging the algorithm.
  let border-from = node-to-path ctx edge#from in
  let border-to = node-to-path ctx edge#to in
  let intersects-from = XPath.get-intersections-with ctx#precision ppat border-from in
  let intersects-to = XPath.get-intersections-with ctx#precision ppat border-to in
  % let _ = display-message (DebugShowValue.show-list DebugShowValue.show-point intersects-from) in
  % let _ = display-message (DebugShowValue.show-list DebugShowValue.show-point intersects-to) in
  ppat
  |> cut-until-last-point ctx#precision intersects-from
  |> cut-at-first-point ctx#precision intersects-to
  |> shorten-prepath ctx#precision edge#shorten
  |> XPath.terminate-path

let edge-to-graphics ctx edge =
  [ draw ctx (edge-to-path ctx edge) ]

let empty-path =
  XPath.start-path (0pt, 0pt) |> XPath.terminate-path

let-rec unite-paths paths =
  match paths with
  | [] -> empty-path
  | x :: [] -> x
  | x :: xs -> XPath.unite-path x (unite-paths xs)

let start-picture ctx = (|
  nodes = [];
  edges = [];
  context = ctx;
|)

let add-node node picture =
  let nodes = node :: picture#nodes in
  (| picture with nodes = nodes |)

let add-edge edge picture =
  let edges = edge :: picture#edges in
  (| picture with edges = edges |)

let-rec get-graphics-list-bbox grlst =
  let nan = 1pt *' (0. /. 0.) in
  match grlst with
  | [] -> ((nan, nan), (nan, nan))
  | x :: [] -> get-graphics-bbox x
  | x :: xs -> XPathUtil.concat-bbox (get-graphics-bbox x) (get-graphics-list-bbox xs)

let-inline ctx \picture picture =
  let node-graphics = List.map (node-to-graphics picture#context) picture#nodes |> List.concat in
  let edge-graphics = List.map (edge-to-graphics picture#context) picture#edges |> List.concat in
  let all-graphics = List.append node-graphics edge-graphics in
  let bbox = get-graphics-list-bbox all-graphics in
  let ((x1,y1),(x2,y2)) = bbox in
  let h = y2 -' y1 in
  let w = x2 -' x1 in
  let d = 0pt in
  inline-graphics w h d (fun (x,y) -> all-graphics |> List.map (shift-graphics (x -' x1, y -' y1)))

in

document (|
  title = {Graphics test};
  author = {sankantsu};
|) '<
  +p {
    foo \picture(
      let text-ctx = get-initial-context 100000cm (command \math) in
      let r = 10pt in
      let node1 = make-text-node text-ctx (0pt, 0pt) {This is a test} in
      let node2 = make-text-node text-ctx (100pt, 30pt) {fgh} in
      let node3 = make-text-node text-ctx (30pt, -50pt) {Another node} in
      let edge1 = make-edge node1 node2 in
      let edge2 = make-edge node1 node3 in
      start-picture default-context
      |> add-node node1
      |> add-node node2
      |> add-node node3
      |> add-edge edge1
      |> add-edge edge2
    ); bar
  }
>