Initial commit

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))