#! /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))