From 758d3325bd40df54a462b5a76317ba84577ee9b3 Mon Sep 17 00:00:00 2001
From: rekado <rekado@elephly.net>
Date: Thu, 1 Sep 2016 21:55:19 +0200
Subject: Initial commit.

---
 scales.scm | 102 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 102 insertions(+)
 create mode 100644 scales.scm

diff --git a/scales.scm b/scales.scm
new file mode 100644
index 0000000..c4c0b6d
--- /dev/null
+++ b/scales.scm
@@ -0,0 +1,102 @@
+(use-modules (srfi srfi-1)
+             (srfi srfi-26))
+
+(define all-notes
+  (circular-list 'a 'ais 'b 'c 'cis 'd 'dis 'e 'f 'fis 'g 'gis))
+
+(define (all-notes-from root)
+  (find-tail (cut eqv? root <>) all-notes))
+
+
+;;; Common scales
+
+(define lydian
+  '(2 2 2 1 2 2 1))
+(define ionian
+  '(2 2 1 2 2 2 1))
+(define mixolydian
+  '(2 2 1 2 2 1 2))
+(define lydian-b7
+  '(2 2 2 1 2 1 2))
+(define altered
+  '(1 2 1 2 2 2 2))
+(define symmetrical-diminished
+  '(1 2 1 2 1 2 1 2))
+(define dorian
+  '(2 1 2 2 2 1 2))
+(define aeolian
+  '(2 1 2 2 1 2 2))
+(define phrygian
+  '(1 2 2 2 1 2 2))
+(define locrian
+  '(1 2 2 1 2 2 2))
+
+
+;;; Tunings
+
+(define tuning-guitar
+  '(e a d g b e))
+
+(define tuning-grand-stick-matched-reciprocal-6+6
+  '((c g d a e b) (c g d a e b)))
+
+
+(define (steps->offsets steps)
+  "Given a list of semitone steps return a pattern of absolute
+pitch offsets."
+  (reverse
+   (fold (lambda (step acc)
+           (cons (+ step (car acc)) acc))
+         '(0) steps)))
+
+(define (scale->notes scale root)
+  (let ((notes (all-notes-from root)))
+    (map (lambda (offset)
+           (list-ref notes offset))
+         (steps->offsets scale))))
+
+(define (fretboard tuning notes frets fret-offset)
+  "Generate a fretboard (a list of lists of notes) for an instrument
+with the given TUNING where the position of the given NOTES are
+indicated for as many FRETS as specified."
+  (let ((keep-notes (lambda (note)
+                      (if (member note notes)
+                          note #f))))
+    (map (lambda (root)
+           (map keep-notes
+                (drop (take (all-notes-from root)
+                            (+ frets fret-offset))
+                      fret-offset)))
+         (reverse tuning))))
+
+;; TODO: keep more metadata, e.g. scale position
+
+
+;;; Printing
+
+(define (print-frets frets)
+  (display "|")
+  (for-each (lambda (note)
+              (format #t "-~3,,,'-,a-|"
+                      (if note note "-")))
+            frets)
+  (format #t "\n"))
+
+(define (print-fretboard fretboard)
+  (for-each print-frets fretboard))
+
+(define (print-stick fretboards)
+  (for-each (compose (lambda _ (format #t "\n"))
+                     print-fretboard)
+            fretboards))
+
+
+
+;;; Examples
+
+(when #f
+  (print-fretboard (fretboard tuning-guitar (scale->notes 'aeolian 'e) 7 5))
+  (print-stick
+   (map (lambda (string-group)
+          (fretboard string-group (scale->notes 'aeolian 'e) 7 5))
+        tuning-grand-stick-matched-reciprocal-6+6)))
-- 
cgit v1.2.3