#! /usr/bin/env guile
SPDX-License-Identifier: CC0-1.0
Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
!#
(use-modules ((ice-9 getopt-long) #:select (getopt-long option-ref))
((ice-9 format) #:select (format))
((ice-9 match) #:select (match match-lambda match-lambda*))
((ice-9 regex) #:select (regexp-substitute string-match))
((ice-9 peg) #:select (define-peg-string-patterns
match-pattern
peg:tree
keyword-flatten))
((srfi srfi-26) #:select (cut))
((sxml simple) #:select (xml->sxml sxml->xml))
((sxml xpath) #:select (sxpath)))
(define %option-spec
'((input (single-char #\i) (value #t))
(output (single-char #\o) (value #t))
(reverse-order (single-char #\r) (value #f))
(font-size (single-char #\s) (value #t))))
(define %options
(getopt-long (command-line) %option-spec))
(define %known-namespaces
'((cc . "http://creativecommons.org/ns#")
(dc . "http://purl.org/dc/elements/1.1/")
(inkscape . "http://www.inkscape.org/namespaces/inkscape")
(rdf . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
(sodipodi . "http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd")
(svg . "http://www.w3.org/2000/svg")
(xlink . "http://www.w3.org/1999/xlink")))
(define* (load-inkscape-svg #:rest args)
(match args
((or () (#f))
(load-inkscape-svg (current-input-port)))
(((? port? port))
(xml->sxml port #:namespaces %known-namespaces))
(((? string? filename))
(call-with-input-file filename
(cut load-inkscape-svg <>)))))
(define sxml
(load-inkscape-svg (option-ref %options 'input #f)))
(define (extract-path-node svg-sxml)
(match ((sxpath '(// (svg:path (@ (inkscape:label
((equal? "connect-the-dots")))))))
sxml)
((path)
path)
(()
(throw '&exception
"Cannot extract object with \"connect-the-dots\" label."))))
(define main-drawing-path-node
(extract-path-node sxml))
(define (extract-path-text node)
(match ((sxpath '(@ d *text*)) node)
((text)
text)
(()
(throw '&exception
"Cannot extract \"d\" attribute of the path."))))
(define point-coords-text
(extract-path-text main-drawing-path-node))
(define-peg-string-patterns
"Pinkscape-svg-path <- Pwhitespace? Pcommand
(Pseparator? Pcommand Parg /
Pseparator? Pcommand /
Pseparator Parg)+
Pwhitespace? !.
Pcommand <-- [MmLlHhVvZzCcSsAaRrBb]
Parg <-- '-'? ([0-9]+ ('.' [0-9]*)? / '.' [0-9]+) ([eE] '-'? [0-9]+)?
Pwhitespace < [ \t\n]+
Pseparator < (',' Pwhitespace? / Pwhitespace)")
(define %forbidden-command-regex
(make-regexp "^[ZzCcSsAaRrBb]$"))
(define (parse-path path-string)
(define peg-tree
(match (match-pattern Pinkscape-svg-path path-string)
(#f
(throw '&exception "The path is of wrong format."))
(peg-struct
(keyword-flatten '(Parg Pcommand) (peg:tree peg-struct)))))
(let loop ((position '(0 0))
(last-commmand #f)
(path-points '())
(to-process peg-tree))
(match (cons last-commmand to-process)
((_)
(reverse path-points))
((_ ('Pcommand (? (cut regexp-exec %forbidden-command-regex <>)
command))
. _)
(throw '&exception
(format #f "The path uses forbidden command \"~a\"." command)))
((#f (not ('Pcommand (or "m" "M")))
. _)
(throw '&exception
"The path starts with neither \"m\" nor \"M\" command."))
(((not #f) ('Pcommand (or "m" "M"))
. _)
(throw '&exception "The path is composite."))
((or (_ ('Pcommand (and (or "m" "M" "L") command))
('Parg coord1) ('Parg coord2)
. rest)
((and (or "M" "L") command) ('Parg coord1) ('Parg coord2)
. rest))
(let ((position* (map string->number (list coord1 coord2))))
(loop position* command (cons position* path-points) rest)))
((or (_ ('Pcommand (and "l" command)) ('Parg coord1) ('Parg coord2)
. rest)
((and (or "m" "l") command) ('Parg coord1) ('Parg coord2)
. rest))
(let* ((relative-coords (map string->number (list coord1 coord2)))
(position* (map + position relative-coords)))
(loop position* command (cons position* path-points) rest)))
((or (_ ('Pcommand (and "v" command)) ('Parg coord)
. rest)
((and "v" command) ('Parg coord)
. rest))
(let* ((relative-coord (string->number coord))
(position* (map + position (list 0 relative-coord))))
(loop position* command (cons position* path-points) rest))))))
(define point-coords
((if (option-ref %options 'reverse-order #f)
reverse identity)
(parse-path point-coords-text)))
(define points-count
(length point-coords))
(define label-coords
(match ((sxpath '(// (svg:g (@ (inkscape:label
((equal? "dots-and-numbers")))))
// svg:tspan @))
sxml)
(()
(map (lambda (coords)
(map + coords '(1 -1)))
point-coords))
(((@ attrs ...) ...)
(unless (= (length attrs) points-count)
(throw '&exception
(format #f "Number of labels (~a) different from number of points (~a)."
(length attrs) points-count)))
(map (lambda (tspan-attrs)
(map (lambda (coord-name)
(string->number (car (assq-ref tspan-attrs coord-name))))
'(x y)))
attrs))))
(define %dot-style
"fill:#777777;fill-opacity:1;stroke:none;")
(define %font-size (option-ref %options 'font-size "7.8373"))
(define %text-style
(format #f "font-size:~apx;font-family:FreeSans;fill:#777777;fill-opacity:1;stroke:none"
%font-size))
(define dots-group-sxml
`(g (@ (inkscape:label "dots"))
,@(map (match-lambda ((x y)
`(circle (@ (style ,%dot-style)
(cx ,x)
(cy ,y)
(r 1.742)))))
point-coords)))
(define labels-group-sxml
`(g (@ (inkscape:label "labels"))
,@(map (match-lambda* ((number (x y))
`(text (@ (xml:space "preserve")
(style ,%text-style)
(x ,x)
(y ,y))
(tspan (@ (x ,x)
(y ,y))
,number))))
(iota (length point-coords) 1)
label-coords)))
(define dots-and-numbers-layer-sxml
`(g (@ (inkscape:groupmode "layer")
(inkscape:label "dots-and-numbers"))
,dots-group-sxml
,labels-group-sxml))
(define %known-namespaces-xmlns-attrs
`((xmlns ,(assoc-ref %known-namespaces 'svg))
. ,(map (match-lambda
((ns-name . ns-url)
(list (string->symbol (format #f "xmlns:~a" ns-name)) ns-url)))
%known-namespaces)))
(define* (transform-svg sxml #:rest layers-to-add)
(let transform ((node sxml))
(match node
;; Process lists starting with '*SOMETHING* without normalization
(((? symbol? sym (= symbol->string (? (cut string-prefix? "*" <>))))
. rest)
`(,sym . ,(map transform rest)))
;; Don't alter attributes by themselves
((and ('@ . _) attr-list)
attr-list)
;; Normalize sxml by adding empty attr lists
(((? symbol? sym)
. (and (not (('@ . _) . _))
rest))
(transform `(,sym (@) . ,rest)))
;; Add xmlns attributes and new svg layers
(('svg:svg attrs . children)
`(svg:svg (,@attrs . ,%known-namespaces-xmlns-attrs)
,@(map transform children)
. ,layers-to-add))
;; Remove previously existing \"dots-and-numbers\" layer
(('svg:g ('@ . (= (cut assoc-ref <> 'inkscape:label)
("dots-and-numbers")))
. _)
"")
;; Recursively process all ordinary nodes' children
((? list? list)
(map transform list))
;; Don't alter strings and symbols by themselves
(something-else
something-else))))
(define* (save-inkscape-svg svg-sxml #:rest args)
(match args
((or () (#f))
(save-inkscape-svg svg-sxml (current-output-port)))
(((? port? port))
(sxml->xml svg-sxml port))
(((? string? filename))
(call-with-output-file filename
(cut save-inkscape-svg svg-sxml <>)))))
(save-inkscape-svg (transform-svg sxml dots-and-numbers-layer-sxml)
(option-ref %options 'output #f))
