diff options
Diffstat (limited to 'make-points.scm')
| -rwxr-xr-x | make-points.scm | 248 |
1 files changed, 248 insertions, 0 deletions
diff --git a/make-points.scm b/make-points.scm new file mode 100755 index 0000000..56c711f --- /dev/null +++ b/make-points.scm @@ -0,0 +1,248 @@ +#! /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)))))) + +(define point-coords + (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)) |