Quick script to draw SVG fretboards. For yak-shaving purposes.

fretboard.rkt

#lang racket

(require racket/draw)


(define string-dist 15)
(define fret-dist 20)
(define strings 6)

(define (draw-gstring dc frets x h)
  (send dc set-pen
        (send the-pen-list find-or-create-pen
              "black" 1 'solid 'butt))
  (send dc draw-line x 0 x h)

  (for ((f frets))
    (send dc set-pen
          (send the-pen-list find-or-create-pen
                "black" 3 'solid 'round))
    (let ((i (if (list? f)
               (begin
                 (send dc set-pen
                       (send/apply the-pen-list find-or-create-pen (cdr f)))
                 (car f))
               f)))
      (send dc draw-point x (- (* i fret-dist) (/ fret-dist 2))))))


(define (car-or-self x)
  (if (list? x)
    (car x)
    x))

(define (fretboard dc notes)
  (define nfrets (with-handlers
                   ((exn:fail? (λ (_) 3)))
                   (add1 (apply max
                                (flatten (map (curry map car-or-self) notes))))))

  (send dc set-pen
        (send the-pen-list find-or-create-pen
              "black" 3 'solid 'butt))
  (send dc draw-line 0 1 (* string-dist (sub1 strings)) 1)

  (send dc set-pen
        (send the-pen-list find-or-create-pen
              "black" 1 'solid 'butt))
  (for ((i (in-range nfrets)))
    (send dc draw-line 0
          (* i fret-dist)
          (* string-dist (sub1 strings))
          (* i fret-dist)))

  (let l ((i 0) (s notes))
    (cond
      ((eq? i strings)
       #t)
      ((null? s)
       (draw-gstring dc '() (* i string-dist) (* fret-dist nfrets))
       (l (add1 i) '()))
      (else
        (draw-gstring dc (car s) (* i string-dist) (* fret-dist nfrets))
        (l (add1 i) (cdr s))))))

(define (make-fretboard-svg file positions)
  (system (string-append "rm " file))
  (let ((i (new svg-dc%
                (width 500)
                (height 500)
                (output file))))
    (send i start-doc "start")
    (send i start-page)
    (send i set-origin 5 5)
    (fretboard i positions)
    (send i end-page)
    (send i end-doc)))

(make-fretboard-svg "1.svg"
                    '((1 3 5)
                      (1 3 5)
                      (2 3 5)
                      (2 3 5)
                      (3 5 6)
                      (3 5 6)))