#!/bin/sh
# -*- scheme -*-
exec guile --debug -e main -s "$0" "$@"
!#
(use-modules (sxml simple)
             (sxml ssax) ;; should use ssax-simple, but doesn't work on old guile-lib
             (sxml transform)
             (sxml xpath)
             (ice-9 format))

;; SVG splitter. Takes an SVG file with N layers, generating N SVG files
;; with one layer.

;; The implementation is messier than it should be because of
;; namespaces. The default XML parser that SSAX provides expands out
;; NCNames as e.g. svg => http://www.w3.org/2000/svg:svg, instead of
;; svg:svg and returning http://www.w3.org/2000/svg as one of the found
;; namespaces. So in order to be able to write back the parsed SXML, we
;; have to define all namespaces that we expect to see, and then re-add
;; xmlns: attributes on the root svg element.
(define (parse-svg file)
  (define *namespaces*
    '((dc . "http://purl.org/dc/elements/1.1/")
      (cc . "http://creativecommons.org/ns#")
      (rdf . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
      (svg . "http://www.w3.org/2000/svg")
      (sodipodi . "http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd")
      (inkscape . "http://www.inkscape.org/namespaces/inkscape")))
  (pre-post-order
   (ssax:xml->sxml 
    (open-input-file file)
    *namespaces*)
   `((svg:svg . ,(lambda (tag attrs . body)
                   (cons* tag
                          (cons
                           '@
                           (append
                            (map (lambda (pair)
                                   (list
                                    (symbol-append 'xmlns: (car pair))
                                    (cdr pair)))
                                 *namespaces*)
                            (cdr attrs)))
                          body)))
     (*TOP* . ,(lambda (tag attrs . body) (cons tag body)))
     (*default* . ,(lambda args args))
     (*text* . ,(lambda (tag t) t)))))

(define (get-layers sxml)
  ((sxpath '(* svg:g)) sxml))

(define (prune-false l)
  (let lp ((in l) (out '()))
    (if (null? in)
        (reverse! out)
        (lp (cdr in) (if (car in) (cons (car in) out) out)))))

(define (make-template layer-sym sxml)
  (pre-post-order
   sxml
   `((svg:svg
      . ,(lambda args
           (prune-false
            (append args (list `(,layer-sym))))))
     (svg:g *preorder* . ,(lambda args #f))
     (*default* . ,(lambda args args))
     (*text* . ,(lambda (tag t) t)))))

(define (process-template layer-sym template layer)
  (pre-post-order
   template
   `((,layer-sym *macro* . ,(lambda args layer))
     (svg:g ((@ ((style . ,(lambda (tag arg)
                             ;; make sure the layer is visible
                             (list tag (string-append arg ";display:block")))))
                . ,(lambda args args)))
            . ,(lambda args args))
     (*default* . ,(lambda args args))
     (*text* . ,(lambda (tag t) t)))))

(define (make-wrapper sxml)
  (let* ((layer-sym (gensym))
         (template (make-template layer-sym sxml)))
    (lambda (layer)
      (process-template layer-sym template layer))))

(define (export-layer layer-sxml index)
  (with-output-to-file (format #f "page-~2,'0D.svg" index)
    (lambda ()
      (SRV:send-reply
       (post-order
        layer-sxml
        (cons*
         `(*TOP* . ,(lambda (tag . body) body))
         ;; older guile-lib doesn't handle *PI*
         `(*PI* *preorder* . ,(lambda (pi tag str) (list "<?" tag " " str "?>")))
         universal-sxslt-rules))))))

(define (export-all-layers sxml)
  (let ((wrap (make-wrapper sxml)))
    (let lp ((layers (get-layers sxml))
             (i 0))
      (if (null? layers)
          (format #t "Generated ~a pages.\n" i)
          (begin
            (export-layer (wrap (car layers)) i)
            (lp (cdr layers) (1+ i)))))))

(define (main args)
  (or (= (length args) 2)
      (begin
        (display "usage: svg-split SVG-FILE\n" (current-error-port))
        (exit 1)))
  (export-all-layers (parse-svg (cadr args))))