; Generate keys
(import (scheme char)
        (chibi)
        (chibi string)
        (chibi sxml)
        (srfi 1)
        (srfi 9)
        (srfi 41))

(define-record-type <glyph>
  (glyph char font size color style)
  glyph?
  (char  glyph-char  glyph-set-char!)
  (font  glyph-font  glyph-set-font!)
  (size  glyph-size  glyph-set-size!)
  (color glyph-color glyph-set-color!)
  (style glyph-style glyph-set-style!))

(define-record-type <path>
  (path contents size color)
  path?
  (contents     path-contents     path-contents!)
  (size         path-size         path-set-size!)
  (color        path-color        path-set-color!))



(define args (cdr (command-line)))

(define INFILE  (first  args))
(define OUTFILE (second args))

(load INFILE)

(define a4-size '(297 . 210))
(define a5-size '(210 . 148))
(define a6-size '(148 . 105))
(define a7-size '(105 . 74))

; Move this to a configuration file or something
(define sticker-radius 3.82); mm
(define page-size a7-size) ;; 96 Stickers at this size

(define x car)
(define y cdr)
(define num number->string)
(define (mm i)
  (string-append (num i) "mm"))

(define style (string-append
"
text {
  stroke: black;
  stroke-width: 0.01;
}
.cuts {
  fill: none;
  stroke-width: 0.1;
  stroke: red;
}
"))


(define (honeycomb sticker-radius top-left bottom-right spacing)
  "Return a function that generates positions for the stickers of size
  `sticker-radius` distributed in a box with `top-left` and `bottom-right`
  corners with `spacing` between them."
  (let* ((current-x (+ spacing sticker-radius (x top-left)))
         (current-y (+ spacing sticker-radius (y top-left)))
         (first #t))
    (lambda ()
      (if first
          (begin
            (set! first #f)
            (cons current-x current-y))
          (begin
            (set! current-x (+ spacing current-x (* 2 sticker-radius)))
            (if (> (+ current-x sticker-radius spacing)
                   (x bottom-right))
                (begin
                  (set! current-x (+ spacing sticker-radius (x top-left)))
                  (set! current-y (+ spacing current-y (* 2 sticker-radius)))
                  (if (> (+ current-y sticker-radius spacing)
                         (y bottom-right))
                      (error "Too many stickers for the provided space"))))
            (cons current-x current-y))))))

(define (circle cx cy r class)
  `(circle (@ (cx    ,cx)
              (cy    ,cy)
              (r     ,r)
              (class ,class))))

(define (rounded-rect cx cy w h r class)
  `(rect (@ (x  ,(- cx (/ w 2)))
            (y  ,(- cy (/ h 2)))
            (width  ,w)
            (height  ,h)
            (rx ,r)
            (ry ,r)
            (class ,class))))

(define (text-unpositioned glyph)
  "Returns a `text` object that is defined to be centered vertically and
  horizontally wrapped in a procedure that must be called to provide it the
  center position of the text. It gets a `glyph` record as an input."
  (lambda (cx cy)
    `(text (@ (x ,cx)
              (y ,(+ 0.1 cy))
              (style ,(string-append "font-style: "  (glyph-style glyph)
                                   "; font-size: "   (glyph-size  glyph)
                                   "; font-family: " (glyph-font  glyph)
                                   "; fill: "        (glyph-color glyph)))
              (text-anchor middle)
              (dominant-baseline central))
           ,(glyph-char glyph))))

(define (path-unpositioned path)
  "Returns a `path` object that is defined to be centered vertically and
  horizontally  in a `g` wrapped in a procedure that must be called to provide
  it the center position. It gets a `path` record as an input."
  (define str number->string)
  (lambda (cx cy)
    `(g (@ (x ,cx)
           (y ,cy)
           (transform ,(string-append
                         "translate(" (str cx) " " (str cy) ")"
                         "scale(" (path-size path) " " (path-size path) ")")))
      (path (@ (d ,(path-contents path))
               (style ,(string-append "; fill: " (path-color path))))))))


(define stickers
  (let ((pos (honeycomb sticker-radius '(0 . 0) page-size 1)))
   (map
    (lambda (contents)
      (let ((position (pos)))
        (cons
          #;(circle
            (x position)
            (y position)
            sticker-radius
            "cuts")
          (rounded-rect
            (x position)
            (y position)
            (* 2 sticker-radius)
            (* 2 sticker-radius)
            1
            "cuts")
          (contents (x position) (y position)))))

    (map (lambda (el)
           (cond ((glyph? el)  (text-unpositioned el))
                 ((path? el)   (path-unpositioned el))))
         glyphs))))


(define cuts     (map car stickers))
(define graphics (map cdr stickers))

(define (dump outport)
  (display
    "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>" outport)
  (display
    (sxml->xml
      `(svg (@ (version "1.1")
               (xmlns:inkscape "http://www.inkscape.org/namespaces/inkscape")
               (width   ,(mm (x page-size)))
               (height  ,(mm (y page-size)))
               (viewBox ,(string-append "0 0 " (num (x page-size))
                                        " "    (num (y page-size)))))
            (defs
              (style ,style))

         (g (@ (id cut)
               (inkscape:groupmode layer)
               (inkscape:label "Cortes"))
            ,@cuts)


         (g (@ (id graph)
               (inkscape:groupmode layer)
               (inkscape:label "Gráficos"))
            ,@graphics)))

    outport))

(call-with-output-file OUTFILE dump)