From ffe04262d689ce202386b0d7914b044c64170219 Mon Sep 17 00:00:00 2001
From: rekado <rekado@elephly.net>
Date: Fri, 30 Sep 2016 00:10:41 +0200
Subject: Add primitive SVG fretboard drawing procedure.

---
 scales/fretboard.scm | 52 +++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 51 insertions(+), 1 deletion(-)

diff --git a/scales/fretboard.scm b/scales/fretboard.scm
index 6802b45..92b3de6 100644
--- a/scales/fretboard.scm
+++ b/scales/fretboard.scm
@@ -22,6 +22,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (scales utils)
+  #:use-module (scales svg)
   #:export (tuning-guitar
             tuning-grand-stick-matched-reciprocal-6+6
 
@@ -29,7 +30,9 @@
             fretboard
 
             print-fretboard
-            print-stick))
+            print-stick
+
+            svg-fretboard))
 
 
 ;;; Tunings
@@ -98,3 +101,50 @@ are indicated for as many FRETS as specified."
   (for-each (compose (lambda _ (format #t "\n"))
                      print-fretboard)
             fretboards))
+
+
+;;; SVG
+
+;; TODO: rewrite to draw strings first, then add markers on top.
+
+(define (svg-fret height width fret)
+  (let ((note (fret-note fret)))
+    `(g ,(list
+          ;; String
+          (line 0     (/ height 2)
+                width (/ height 2)
+                "stroke-width: 2; stroke: #000")
+          ;; Fret
+          (line width 0
+                width height
+                "stroke-width: 3; stroke: #000")
+          (if note
+              (list
+                ;; Position marker
+                (circle (/ width 2) (/ height 2)
+                        (- (/ height 2) 4)
+                        (if (zero? (scale-note-offset note))
+                            "fill: #faafaa; stroke: #888"
+                            "fill: #fff; stroke: #aaa"))
+                ;; Note name
+                (text (/ width 2) (/ height 2)
+                      (format #f "~a"
+                              (if (zero? (scale-note-offset note))
+                                  (string-upcase (symbol->string (scale-note-note note)))
+                                  (scale-note-note note)))
+                      "text-anchor: middle; alignment-baseline: middle"))
+              '())))))
+
+(define (svg-frets frets)
+  `(g ,(map (match-lambda
+              ((offset fret)
+               (translate offset 0 (svg-fret 32 64 fret))))
+            (zip (iota (length frets) 0 64)
+                 frets))))
+
+(define (svg-fretboard fretboard)
+  (svg (map (match-lambda
+              ((offset frets)
+               (translate 0 offset (svg-frets frets))))
+            (zip (iota (length fretboard) 0 32)
+                 fretboard))))
-- 
cgit v1.2.3