Chord progressions with F#

chords.fsx

open System

type Interval =
    | PerfectUnison
    | MinorSecond
    | MajorSecond
    | MinorThird | AugmentedSecond      // Enharmonically the same in 12TET
    | MajorThird
    | PerfectFourth
    | DiminishedFifth | AugmentedFourth // Enharmonically the same in 12TET
    | PerfectFifth
    | MinorSixth | AugmentedFifth       // Enharmonically the same in 12TET
    | MajorSixth | DiminishedSeventh    // Enharmonically the same in 12TET
    | MinorSeventh
    | MajorSeventh
    | Octave
    | OctaveUp of Interval

type Note =
    | C
    | CsDb
    | D
    | DsEb
    | E
    | F
    | FsGb
    | G
    | GsAb
    | A
    | AsBb
    | B

let chromaticBase = [ C; CsDb; D; DsEb; E; F; FsGb; G; GsAb; A; AsBb; B ]
let tones = Seq.initInfinite (fun i -> chromaticBase[i % chromaticBase.Length])

module Interval =
    let rec inSemitones interval =
        match interval with
        | PerfectUnison -> 0
        | MinorSecond -> 1
        | MajorSecond -> 2
        | AugmentedSecond
        | MinorThird -> 3
        | MajorThird -> 4
        | PerfectFourth -> 5
        | AugmentedFourth
        | DiminishedFifth -> 6
        | PerfectFifth -> 7
        | AugmentedFifth
        | MinorSixth -> 8
        | MajorSixth
        | DiminishedSeventh -> 9
        | MinorSeventh -> 10
        | MajorSeventh -> 11
        | Octave -> 12
        | OctaveUp interval -> 12 + inSemitones interval

    let rec fromSemitones =
        function
        | 0 -> PerfectUnison
        | 1 -> MinorSecond
        | 2 -> MajorSecond
        | 3 -> MinorThird
        | 4 -> MajorThird
        | 5 -> PerfectFourth
        | 6 -> DiminishedFifth
        | 7 -> PerfectFifth
        | 8 -> MinorSixth
        | 9 -> MajorSixth
        | 10 -> MinorSeventh
        | 11 -> MajorSeventh
        | 12 -> Octave
        | x when x > 12 -> fromSemitones (x - 12)
        | _ -> failwith "Can't map this"

type Chord =
    { Root: Note; IntervalsFromRoot: Interval list }

module Chord =
    let getNotes chord =
        let indexOfRoot = Seq.findIndex (fun note -> note = chord.Root) tones
        let intervals =
            List.map Interval.inSemitones chord.IntervalsFromRoot
            |> List.sort

        [   chord.Root, 0
            for interval in intervals do
                // this is just lazy, one almost never goes over 2 octaves..
                let octaveInfo = if interval > 12 - indexOfRoot then 1 else 0
                Seq.item (indexOfRoot + interval) tones, octaveInfo ]


module Triads =
    let major root = { Root = root; IntervalsFromRoot = [MajorThird; PerfectFifth] }
    let minor root = { Root = root; IntervalsFromRoot = [MinorThird; PerfectFifth] }
    let diminished root = { Root = root; IntervalsFromRoot = [MinorThird; DiminishedFifth] }
    let augmented root = { Root = root; IntervalsFromRoot = [MajorThird; AugmentedFifth] }

module Modifications =
    let with6b chord = { chord with IntervalsFromRoot = MinorSixth :: chord.IntervalsFromRoot }
    let with6 chord = { chord with IntervalsFromRoot = MajorSixth :: chord.IntervalsFromRoot }
    let withMinor7 chord = { chord with IntervalsFromRoot = MinorSeventh :: chord.IntervalsFromRoot }
    let withMajor7 chord = { chord with IntervalsFromRoot = MajorSeventh :: chord.IntervalsFromRoot }
    let withDiminished7 chord = { chord with IntervalsFromRoot = DiminishedSeventh :: chord.IntervalsFromRoot }
    let with9b chord = { chord with IntervalsFromRoot = OctaveUp(MinorSecond) :: chord.IntervalsFromRoot }
    let with9 chord = { chord with IntervalsFromRoot = OctaveUp(MajorSecond) :: chord.IntervalsFromRoot }
    let with9s chord = { chord with IntervalsFromRoot = OctaveUp(AugmentedSecond) :: chord.IntervalsFromRoot }
    let with11 chord = { chord with IntervalsFromRoot = OctaveUp(PerfectFourth) :: chord.IntervalsFromRoot }
    let with13b chord = { chord with IntervalsFromRoot = OctaveUp(MinorSixth) :: chord.IntervalsFromRoot }
    let with13 chord = { chord with IntervalsFromRoot = OctaveUp(MajorSixth) :: chord.IntervalsFromRoot }

module TetraChords =
    open Modifications
    let seventh =  Triads.major >> withMinor7
    let minorSeventh = Triads.minor >> withMinor7
    let majorSeventh = Triads.major >> withMajor7
    let halfDiminished = Triads.diminished >> withMinor7
    let diminished = Triads.diminished >> withDiminished7
    let minorMajorSeventh = Triads.minor >> withMajor7

module MiscChords =
    open Modifications
    let power root = { Root = root; IntervalsFromRoot = [PerfectFifth; Octave] }
    let suspended4 root = { Root = root; IntervalsFromRoot = [PerfectFourth; PerfectFifth] }
    let eleventh = TetraChords.seventh >> with11
    let add11 = Triads.major >> with11

type Scale = int list
module Scales =
    let private rotate steps list =
        List.splitAt steps list |> fun (x,y)-> List.append y x

    let major = [2; 2; 1; 2; 2; 2; 1]
    let harmonicMinor = [2; 1; 2; 2; 1; 3; 1]
    let melodicMinor = [2; 1; 2; 2; 2; 2; 1]

    module Modes =
        let ionian = major
        let dorian = rotate 1 major
        let phrygian = rotate 2 major
        let lydian = rotate 3 major
        let mixolydian = rotate 4 major
        let aeolian = rotate 5 major
        let locrian = rotate 6 major

    let minor = Modes.aeolian

    let getNotes key (scale: Scale) =
        let indexOfRoot = Seq.findIndex (fun note -> note = key) tones
        let _, notes = List.fold (fun (interval, notes) value -> interval+value, Seq.item (indexOfRoot + interval + value) tones :: notes) (0,[key]) scale
        List.rev (List.tail notes)

    let getNotesWithIntervals key (scale: Scale) =
        let indexOfRoot = Seq.findIndex (fun note -> note = key) tones
        let _, notes =
            List.fold
                (fun (interval, notes) value -> interval+value, (Seq.item (indexOfRoot + interval + value) tones, value) :: notes)
                (0,[key, scale[indexOfRoot]])
                scale
        List.rev (List.tail notes)

    let getSemitonesToRoot scale =
        let _, intervals = List.fold (fun (interval, intervals) value -> interval+value, (interval + value) :: intervals) (0,[0]) scale
        List.rev (List.tail intervals)

type HarmonicFunction =
    | I    // Tonic
    | II   // Super-Tonic
    | III  // Mediant
    | IV   // Sub-Dominant
    | V    // Dominant
    | VI   // Sub-Mediant
    | VII  // Leading tone

module Harmony =

    // type Progression =
    //     { Key: Note
    //       Scale: Scale
    //       Chords: HarmonicFunction list }

    let mapToScaleIndex =
        function
        | I -> 0
        | II -> 1
        | III -> 2
        | IV -> 3
        | V -> 4
        | VI -> 5
        | VII -> 6

    let private infinite (scale: _ list) = Seq.initInfinite (fun i -> scale[i % scale.Length])

    let buildTetrachord key scale harmonicFunction =
        let scaleNotes = Scales.getNotesWithIntervals key scale |> infinite
        let indexOfKey = Seq.findIndex (fun (note, _) -> note = key) scaleNotes
        let indexOfChordRoot = indexOfKey + (mapToScaleIndex harmonicFunction)
        let rootNote, _ = Seq.item indexOfChordRoot scaleNotes

        let rec getChordNotes start index totalInterval notes =
            if List.length notes >= 4 then
                notes
            else
                let note, interval = Seq.item (start + index) scaleNotes
                let semitonesFromRoot = totalInterval + interval
                printfn $"{note} {interval} {totalInterval}"
                if index % 2 = 0 then
                    getChordNotes start (index + 1) semitonesFromRoot ((note, semitonesFromRoot) :: notes)
                else
                    getChordNotes start (index + 1) semitonesFromRoot notes
        let chordNotes = getChordNotes indexOfChordRoot 1 0 [ rootNote, 0 ] |> List.rev

        printfn "%A" chordNotes

        match chordNotes with
        | (root, _) :: rest ->
            { Root = root
              IntervalsFromRoot =
                [ for (_ ,interval) in rest do
                    Interval.fromSemitones interval ]}
        | _ -> failwith ""

    let buildTetrachordProgression key scale progression =
        progression
        |> List.map (buildTetrachord key scale)


module SonicPi =
    let baseOctave = 4
    let toSonicPiNote (note, octaveDiff) =
        match note with
        | C -> "C"
        | CsDb -> "Cs"
        | D -> "D"
        | DsEb -> "Ds"
        | E -> "E"
        | F -> "F"
        | FsGb -> "Fs"
        | G -> "G"
        | GsAb -> "Gs"
        | A -> "A"
        | AsBb -> "As"
        | B -> "B"
        |> fun n -> sprintf ":%s%i" n (baseOctave + octaveDiff)
    let printChord chord  =
        Chord.getNotes chord
        |> List.map toSonicPiNote
        |> fun notes -> $"play [{String.Join(',', notes)}]"

    let printChordProgression stepDuration chords =
        chords
        |> List.map printChord
        |> List.map (fun chord -> $"{chord}, release: {stepDuration}{Environment.NewLine}sleep {stepDuration}")
        |> fun chords -> String.Join(Environment.NewLine, chords)


let fSharp7sharp9 = TetraChords.seventh FsGb |> Modifications.with9s
Chord.getNotes fSharp7sharp9

SonicPi.printChord fSharp7sharp9

Scales.getNotes FsGb Scales.minor

let ``F#m`` = Triads.minor FsGb

Scales.getSemitonesToRoot Scales.minor |> List.map Interval.fromSemitones

Scales.getNotesWithIntervals D Scales.major

Harmony.buildTetrachord D Scales.major I

let one_four_five = Harmony.buildTetrachordProgression D Scales.major [I; IV; V; I]
let one_two_five = Harmony.buildTetrachordProgression D Scales.major [I; II; V; I]
let one_five_six_four = Harmony.buildTetrachordProgression D Scales.major [I; V; VI; IV]

let ``I-IV-V-I`` = Harmony.buildTetrachordProgression FsGb Scales.major [I; IV; V; I]

``I-IV-V-I``
|> SonicPi.printChordProgression 2
|> printfn "%s"