path: root/stickers.scm

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

(define a4-size   '(297 . 210))
(define a5-size   '(210 . 148))
(define a6-size   '(148 . 105))
(define a7-size   '(105 . 74))
;https://unicode-table.com/en/2B7E/
(define es-chars  (string->list "ABCDEFGHIJKLMNÑOPQRSTUVWXYZ"))
(define en-chars  (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
(define uk-chars  (string->list "АБВГҐДЕЄЖЗИІЇЙКЛМНОПРСТУФХЦЧШЩЬЮЯ"))
(define ru-chars  (string->list "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ" ))
(define numbers   (string->list "1234567890"))
(define brackets  (string->list "()[]{}<>"))
(define punct     (string->list ",.:;_"))
(define symbols   (string->list "\\|@#~$%&^`´\"'"))
(define math      (string->list "+-*/="))
(define tab       (list "⇥"))
(define backspace (list "⟵"))
(define arrows    (string->list "←↑→↓"))
(define upcase    (string->list "⇧⇧⇪"))
(define enter     (list "⏎"))
(define modifiers (list "Ctrl" "Ctrl" "Alt" "AltGr" "Esc" "Del" "Fn"))
(define pagers    (list "PgUp" "PgDn"))
(define media     (string->list ""))

(define-record-type <config>
  (make-config page-size sticker-radius stickers)
  config?
  (page-size       config-page-size       set-config-page-size!)
  (sticker-radius  config-sticker-radius  set-config-sticker-radius!)
  (stickers        config-stickers        set-config-stickers!))

(define-record-type <glyph>
  (make-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>
  (make-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))

(define (load* file)
  "Eval the file in current environment"
  (let ((code (call-with-input-file file
                                    (lambda (p)
                                      (let loop ((x (read p)))
                                        (if (eof-object? x)
                                          '()
                                          (cons x (loop (read p)))))))))
    (let loop ((l code))
      (let* ((cur  (car l))
             (next (cdr l))
             (x    (eval cur)))
          (if (null? next)
            x
            (loop next))))))

;; Needs to return a config file
(define config (load* INFILE))

(define sticker-radius (config-sticker-radius config))
(define page-size      (config-page-size config))
(define glyphs         (config-stickers config))

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