;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;

;; A collection of functions for working with pitch class sets

;; and interval sets

;;

;; A pitch class in this library is taken to be a

;; list of MIDI note values from the first octave (0-11)

;; from which other pitches are compared using modulo 12.

;; Therefore, 0 = C, 1 = C#, etc..

;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Define basic diatonic major

(define *pc:diatonic-major*

'((i . (0 . ^))

(i6 . (0 . ^6))

(i64 . (0 . ^64))

(i7 . (0 . ^7))

(i- . (0 . -))

(i-7 . (0 . -7))

(n . (1 . ^)) ; neopolitan

(n6 . (1 . ^6)) ; neopolitan

(ii . (2 . -))

(ii6 . (2 . -6))

(ii7 . (2 . -7))

(ii9 . (2 . -9))

(ii^ . (2 . ^))

(ii^7 . (2 . ^7))

(iii . (4 . -))

(iii6 . (4 . -6))

(iii7 . (4 . -7))

(iii^ . (4 . ^))

(iii^7 . (4 . ^7))

(iv . (5 . ^))

(iv6 . (5 . ^6))

(iv7 . (5 . ^7))

(iv- . (5 . -))

(iv-7 . (5 . -7))

(v . (7 . ^))

(v6 . (7 . ^6))

(v7 . (7 . 7))

(v- . (7 . -))

(v-7 . (7 . -7))

(vi . (9 . -))

(vi6 . (9 . -6))

(vi7 . (9 . -7))

(vi^ . (9 . ^))

(vi^7 . (9 . ^7))

(viio . (11 . o))

(viio7 . (11 . o7))

(vii . (11 . o))

(vii7 . (11 . -7b5))

))

;; Define basic diatonic minor

(define *pc:diatonic-minor*

'((i . (0 . -))

(i6 . (0 . -6))

(i64 . (0 . -64))

(i7 . (0 . -7))

(i^ . (0 . ^))

(i^6 . (0 . ^6))

(i^64 . (0 . ^64))

(i^7 . (0 . ^7))

(n . (1 . ^)) ; neopolitan

(n6 . (1 . ^6)) ; neopolitan

(ii . (2 . o))

(ii6 . (2 . o6))

(ii7 . (2 . o7))

(ii- . (2 . -))

(ii-6 . (2 . -6))

(ii-7 . (2 . -7))

(ii^ . (2 . ^))

(ii^7 . (2 . ^7))

(iii . (3 . ^))

(iii6 . (3 . ^6))

(iii7 . (3 . ^7))

(iii- . (3 . -))

(iii-6 . (3 . -6))

(iii-7 . (3 . -7))

(iv . (5 . -))

(iv6 . (5 . -6))

(iv7 . (5 . -7))

(iv^ . (5 . ^))

(iv^6 . (5 . ^6))

(iv^7 . (5 . ^7))

(v . (7 . ^))

(v^ . (7 . ^))

(v6 . (7 . ^6))

(v7 . (7 . 7))

(v- . (7 . -))

(v-6 . (7 . -6))

(v-7 . (7 . -))

(vi . (8 . ^))

(vi6 . (8 . ^6))

(vi7 . (8 . ^7))

(vi- . (8 . -))

(vi-6 . (8 . -6))

(vi-7 . (8 . -7))

(vii . (10 . ^))

(vii6 . (10 . ^6))

(vii7 . (10 . ^7))

(viio . (11 . o)) ;raised 7 (dim)

(viio6 . (11 . o6)) ;raised 7 (dim)

(viio7 . (11 . o7)) ; raised 7 (dim)

))

;; various scales defined as pc sets

(define *pc:scales*

'((pentatonic . (2 2 3 2))

(wholetone . (2 2 2 2 2))

(chromatic . (1 1 1 1 1 1 1 1 1 1 1))

(octatonic . (2 1 2 1 2 1 2))

(messiaen1 . (2 2 2 2 2))

(messiaen2 . (2 1 2 1 2 1 2))

(messiaen3 . (2 1 1 2 1 1 2 1))

(messiaen4 . (1 1 3 1 1 1 3))

(messiaen5 . (1 4 1 1 4))

(messiaen6 . (2 2 1 1 2 2 1))

(messiaen7 . (1 1 1 2 1 1 1 1 2))

(ionian . (2 2 1 2 2 2))

(dorian . (2 1 2 2 2 1))

(phrygian . (1 2 2 2 1 2))

(lydian . (2 2 2 1 2 2))

(lydian-mixolydian . (2 1 2 1 2 1 2))

(mixolydian . (2 2 1 2 2 1))

(aeolian . (2 1 2 2 1 2))

(locrian . (1 2 2 1 2 2))))

; Define basic chord symbols

(define *pc:chord-syms*

'((^ . (0 4 7))

(^sus . (0 5 7))

(^6 . (4 7 0))

(^64 . (7 0 4))

(^7 . (0 4 7 11))

(^65 . (4 7 11 0))

(^43 . (7 11 0 4))

(^42 . (11 0 4 7))

(^2 . (11 0 4 7))

(^7#4 . (0 4 7 11 6))

(^9 . (0 4 7 11 2))

(7 . (0 4 7 10))

(9 . (0 4 7 10 2))

(65 . (4 7 10 0))

(43 . (7 10 0 4))

(2 . (10 0 4 7))

(42 . (10 0 4 7))

(- . (0 3 7))

(-sus . (0 5 7))

(-6 . (3 7 0))

(-64 . (7 0 3))

(-7 . (0 3 7 10))

(-65 . (3 7 10 0))

(-43 . (7 10 0 3))

(-42 . (10 0 3 7))

(-2 . (10 0 3 7))

(-9 . (0 3 7 10 2))

(o . (0 3 6))

(o6 . (3 6 0))

(o64 . (6 0 3))

(o7 . (0 3 6 8))

(o65 . (3 6 8 0))

(o43 . (6 8 0 3))

(o42 . (8 0 3 6))

(o2 . (8 0 3 6))

(-7b5 . (0 3 6 9))))

(define *pc:chord-syms-scales*

'((^ . 'ionian)

(^sus . 'mixolydian)

(^6 . 'ionian)

(^64 . 'ionian)

(^7 . 'ionian)

(^65 . 'ionian)

(^43 . 'ionian)

(^42 . 'ionian)

(^2 . 'ionian)

(^7#4 . 'ionian)

(^9 . 'ionian)

(7 . 'mixolydian)

(9 . 'mixolydian)

(65 . 'mixolydian)

(43 . 'mixolydian)

(2 . 'mixolydian)

(42 . 'mixolydian)

(- . 'dorian)

(-sus . 'mixolydian)

(-6 . 'dorian)

(-64 . 'dorian)

(-7 . 'dorian)

(-65 . 'dorian)

(-43 . 'dorian)

(-42 . 'dorian)

(-2 . 'dorian)

(-9 . 'dorian)

(o . 'locrian)

(o6 . 'locrian)

(o64 . 'locrian)

(o7 . 'locrian)

(o65 . 'locrian)

(o43 . 'locrian)

(o42 . 'locrian)

(o2 . 'locrian)

(-7b5 . 'locrian)))

(define *pc:chord-syms-dict* (objc:list->nsdictionary *pc:chord-syms*))

;; returns a scale based on a chord (standard jazz translations)

(define *pc:chord->scale*

'((i . (0 . ionian))

(i7 . (0 . ionian))

(ii . (2 . dorian))

(ii7 . (2 . dorian))

(ii9 . (2 . dorian))

(iii . (4 . phrygian))

(iii7 . (4 . phrygian))

(iv . (5 . lydian))

(iv7 . (5 . lydian))

(v . (7 . mixolydian))

(v7 . (7 . mixolydian))

(vi . (9 . aeolian))

(vi7 . (9 . aeolian))

(vii . (11 . locrian))

(vii7 . (11 . locrian))))

;; A predicate for calculating if pitch is in pc

;;

;; arg 1: pitch to check against pc

;; arg 2: pc to check pitch against

;;

;; retuns true or false

;;

(define pc:?

(lambda (pitch pc)

(if (list? (member (modulo pitch 12) pc))

#f)))

;; quantize pc

;; Always slelects a higher value before a lower value where distance is equal.

;;

;; arg 1: pitch to quantize to pc

;; arg 2: pc to quantize pitch against

;;

;; returns quntized pitch or #f if non available

;;

(define pc:quantize

(lambda (pitch-in pc)

(let loop ((inc 0)

(pitch (round pitch-in)))

(cond ((pc:? (+ pitch inc) pc) (+ pitch inc))

((pc:? (- pitch inc) pc) (- pitch inc))

((< inc 7) (loop (+ inc 1) pitch))

(else (print-notification "no pc value to quantize to" pitch pc)

#f)))))

;; quantize pc

;; Always slelects a lower value before a higher value where distance is equal.

;;

;; arg 1: pitch to quantize to pc

;; arg 2: pc to quantize pitch against

;;

;; returns quntized pitch or #f if non available

;;

(define pc:quantize-low

(lambda (pitch-in pc)

(let loop ((inc 0)

(pitch (round pitch-in)))

(cond ((pc:? (- pitch inc) pc) (- pitch inc))

((pc:? (+ pitch inc) pc) (+ pitch inc))

((< inc 7) (loop (+ inc 1) pitch))

(else (print-notification "no pc value to quantize to" pitch pc)

#f)))))

;; select random pitch from pitch class

;; bounded by lower and upper (inclusive lower exclusive upper)

;;

;; arg 1: lower bound (inclusive)

;; arg 2: upper bound (exclusive)

;; arg 3: pitch class

;;

;; returns -1 if no valid pitch was found

;;

(define pc:random

(lambda (lower upper pc)

(if (null? pc)

-1

(let loop ((val (random lower upper)) (count 0))

(if (> count 50)

-1

(if (memv (modulo val 12) pc)

val

(loop (random lower upper) (+ count 1))))))))

;; select pitch from pitch class relative to a given pitch

;;

;; 1st: bass pitch

;; 2nd: pc relationship to bass pitch (max is abs 7)

;; 3rd: pitch class

;;

;; example:

;; (pc:relative 64 -2 '(0 2 4 5 7 9 11)) => 60

;; (pc:relative 69 3 '(0 2 4 5 7 9 11)) => 74

;;

(define pc:relative

(lambda (pitch i pc)

(if (= i 0) pitch

(let ((inc (if (negative? i) - +)))

(let loop ((p (inc pitch 1)) (cnt 0))

(if (pc:? p pc) (set! cnt (inc cnt 1)))

(if (= cnt i) p

(loop (inc p 1) cnt)))))))

;; pc:make-chord

;; creates a list of "number" pitches between "lower" and "upper"

;; bounds from the given "pc". a division of the bounds

;; by the number of elements requested breaks down the selection into

;; equal ranges from which each pitch is selected.

;; make-chord attempts to select pitches of all degrees of the pc.

;; it is possible for elements of the returned chord to be -1 if no

;; possible pc is available for the given range.

;; non-deterministic (i.e. result can vary each time)

;;

;; arg1: lower bound (inclusive)

;; arg2: upper bound (exclusive)

;; arg3: number of pitches in chord

;; arg4: pitch class

;;

;; example: c7

;; (pc:make-chord 60 85 4 '(0 4 7 10)) => (60 70 76 79)

;;

(define pc:make-chord

(lambda (lower upper number pc)

(let ((chord '()))

(let loop ((l lower)

(u upper)

(n number)

(p pc))

(if (< n 1)

(cl:sort (cl:remove -1 chord) <) ; lowest pitch to highest pitch remove -1s

(let* ((range (- u l))

(gap (round (/ range n)))

(pitch (pc:random l (+ l gap) p)))

(if (< pitch 0) ; if new pitch is -1 try from whole range

(set! chord (cons (pc:random lower upper p) chord))

(set! chord (cons pitch chord)))

(loop (+ l gap)

(- n 1)

(if (> (length p) 1)

(cl:remove (modulo (car chord) 12) p)

pc))))))))

;; Returns a scale degree of a given value (pitch) based on a pc

(define pc:degree

(lambda (value pc)

(let loop ((i 1)

(lst pc))

(if (null? lst)

(begin (print-notification "pitch not in pc") -1)

(if (= (car lst) (modulo value 12))

(loop (+ i 1) (cdr lst)))))))

;; quantize the values of lst to pc

(define pc:quantize-list

(lambda (lst pc)

(map (lambda (i)

(pc:quantize i pc))

lst)))

;; retrograde list

(define ivl:retrograde reverse)

;; invert list paying no attention to key

(define ivl:invert

(lambda (lst . args)

(let ((pivot (if (null? args)

(car lst)

(car args))))

(cons (car lst) (map (lambda (i)

(- pivot (- i pivot)))

(cdr lst))))))

;; transpose list paying no attention to key

(define ivl:transpose

(lambda (val lst)

(map (lambda (i)

(+ i val))

lst)))

;; expand/contract list by factor paying no attention to key

(define ivl:expand/contract

(lambda (lst factor)

(cons (car lst)

(let loop ((old (car lst))

(l (cdr lst))

(current (car lst))

(newlst '()))

(if (null? l)

(reverse newlst)

(loop (car l)

(cdr l)

(+ current (* factor (- (car l) old)))

(cons (real->integer (+ current (* factor (- (car l) old))))

newlst)))))))

;; invert the values of lst quantizing to pc

(define pc:invert

(lambda (lst pc . args)

(if (null? args)

(pc:quantize-list (ivl:invert lst) pc)

(pc:quantize-list (ivl:invert lst (car args)) pc))))

;; transpose the values of lst quantizing to pc

(define pc:transpose

(lambda (val lst pc)

(pc:quantize-list (ivl:transpose val lst) pc)))

;; expand/contract lst by factor quantizing to pc

(define ivl:expand/contract

(lambda (lst factor pc)

(pc:quantize-list (ivl:expand/contract lst factor) pc)))

;; returns a scale type based on a chord type (basic jazz modal theory)

(define pc:chord->scale

(lambda (root type)

(pc:scale (modulo (+ (cadr (assoc type *pc:chord->scale*)) root) 12)

(cddr (assoc type *pc:chord->scale*)))))

;; returns a scale type based on a given root

(define pc:scale

(lambda (root type)

(if (assoc type *pc:scales*)

(let loop ((l (cdr (assoc type *pc:scales*)))

(current root)

(newlst '()))

(if (null? l)

(reverse (cons current newlst))

(loop (cdr l) (modulo (+ current (car l)) 12) (cons current newlst))))

(begin (print-notification "Scale type not found." *pc:scales*) #f))))

;; returns a chord following basic diatonic harmony rules

;; based on root (0 for C etc.) maj/min ('- or '^) and degree (i-vii)

(define pc:diatonic

(lambda (root maj-min degree)

(let ((val (assoc degree

(if (equal? '^ maj-min)

*pc:diatonic-major*

*pc:diatonic-minor*))))

(pc:chord (modulo (+ root (cadr val)) 12) (cddr val)))))

;; returns a chord following basic diatonic harmony rules

;; based on root (0 for C etc.) maj/min ('- or '^) and degree (i-vii)

(define pc:diatonic-dict

(lambda (root maj-min degree)

(let ((val (objc->list (objc:call (if (equal? '^ maj-min)

*pc:diatonic-major-dict*

*pc:diatonic-minor-dict*)

"objectForKey:" (symbol->string degree)))))

(pc:chord (modulo (+ root (cadr val)) 12) (cddr val)))))

;; returns a chord given a root and type

;; see *pc:chord-syms* for currently available types

;;

;; e.g. (pc:chord 0 '^7) => '(0 4 7 11)

(define pc:chord

(lambda (root type)

(let ((chord (assoc type *pc:chord-syms*)))

(if chord

(let loop ((l (cdr chord))

(newlst '()))

(if (null? l)

(reverse newlst)

(loop (cdr l) (cons (modulo (+ (car l) root) 12) newlst))))

(begin (print-notification "Chord type not found." chord) #f)))))

;; returns chord options for root in maj-min key of pc

;;

;; e.g. (pc:chord-options 0 '^ (pc:scale 0 'ionian)) => ((0 4 7) (0 4 7 11) (0 5 7) (0 4 7 11 2) (0 4 7 11 6))

(define pc:chord-options

(lambda (root maj-min pc)

(let ((major7 '(^ ^7 ^sus ^9 ^7#4))

(dom7 '(^ 7 ^sus 9))

(minor7 '(- -7 -sus -9))

(dim7 '(o -7b5 o7))

(degree (pc:degree root pc)))

(map (lambda (sym)

(pc:chord root sym))

(if (equal? maj-min '^)

(case degree

((-1) '())

((1 4) major7)

((5) dom7)

((2 3 6) minor7)

((7) dim7))

(case degree

((-1) '())

((1 4 6) minor7)

((3) major7)

((5) (append minor7 dom7))

((2) dim7)

((7) (append dom7 dim7))))))))

;; make a chord that is fixed at either the 'top or the 'bottom

;; where fixed is as close as the chord allows to fix-point

;; defaults to bottom

;;

;; (pc:make-chord-fixed 60 3 '(0 3 7)) => (60 63 67)

;; (pc:make-chord-fixed 60 3 '(0 3 7) 'top) => (51 55 60)

;;

(define pc:make-chord-fixed

(lambda (fix-point number pc . args)

(if (< number 1)

'()

(let* ((fixd (modulo fix-point 12))

(place (if (null? args) 'bottom (car args)))

(bass (- fix-point fixd))

(chord (if (eq? place 'bottom) pc (reverse pc)))

(v (map (lambda (pc) (abs (- fixd pc))) chord))

(minim (apply min v))

(start (- (length v) (length (member minim v)))))

(let loop ((i 0)

(new-lst '())

(bb bass)

(lst (list-tail chord start)))

(if (< i number)

(loop (+ i 1)

(cons (+ bb (car lst)) new-lst)

(if (null? (cdr lst))

((if (null? args) + -) bb 12)

bb)

(if (null? (cdr lst))

chord

(cdr lst)))

(if (eq? place 'bottom)

(reverse new-lst)

new-lst)))))))

(define pc:distance-of-chord

(lambda (chd pc)

(apply + (map (lambda (p)

(pc:distance p pc))

chd))))

;; distance between pitch and a pc

(define pc:distance

(lambda (pitch pc)

(let ((p (modulo pitch 12)))

(car (cl:sort (map (lambda (class)

(let ((val (abs (- p class))))

(abs (if (< val (- 12 val)) val (- 12 val)))))

pc) <)))))

;; returns the pitch in plst that is closest to the pc set

;; if multiple pitches in plst are the closest return the first

(define pc:find-closest

(lambda (plst pc)

(cdar (cl:sort (map (lambda (p)

(cons (pc:distance p pc) p))

plst)

(lambda (a b) (if (< (car a) (car b)) #t #f))))))

;; find shortest part movement from chord to pc

(define pc:move-chord

(lambda (chord pc . args)

(let loop ((pci pc)

(chda chord)

(chdb '()))

(if (null? pci) (set! pci pc))

(if (null? chda)

(cl:sort chdb <)

(let* ((match (pc:find-closest chda pci))

(new-pitch (if (> (random) .5)

(pc:quantize-low match pci)

(pc:quantize match pci))))

(loop (remove-first (modulo new-pitch 12) pci)

(remove-first match chda)

(cons new-pitch chdb)))))))

;; returns the type of scale given a pc or the pc itself

;; if no known scale is found

(define pc:scale-from-pc

(lambda (pc)

(let ((scale (let loop ((scale pc)

(ivls '()))

(if (null? (cdr scale))

(reverse ivls)

(loop (cdr scale) (cons (let ((v (- (cadr scale) (car scale))))

(if (< v 0)

(+ 12 v)

v)) ivls))))))

(let check ((scales *pc:scales*))

(if (null? scales)

(if (equal? scale (cdar scales))

(caar scales)

(check (cdr scales))))))))

;; returns a pc-set based on a list of intervals

;; plst is the seed for the progression

;; usually this will be a list with one element

(define pc:from-intervals

(lambda (plst intervals)

(if (null? intervals)

(reverse plst)

(pc:from-intervals (cons (modulo (+ (car plst)

(car ivls))

12)

plst)

(cdr intervals)))))

;returns a pc-set based on a list of steps a beginning pitch class and a pc-set

(define pc:from-steps

(lambda (pitch steps pc)

(let loop ((slst steps)

(plst (list pitch)))

(if (null? slst)

(reverse plst)

(loop (cdr slst)

(cons (modulo (pc:relative (car plst) (car slst) pc) 7) plst))))))

;; attempts to return a reasonable scale based on the chord and root provided

(define pc:scale-from-chord

(lambda (root chord)

(let ((res (cl:find-if (lambda (v)

(equal? (car v) chord))

(map (lambda (scale)

(cons (cl:intersection chord scale) scale))

(map (lambda (type)

(pc:scale root type))

'(ionian aeolian mixolydian lydian phrygian locrian

dorian lydian-mixolydian wholetone chromatic))))))

(if (pair? res)

(cdr res)

chord))))

;; genereate a melody from a list of steps in a (pc) pitch class

(define pc:melody-by-step

(lambda (starting-pitch steps pc . args)

(if (null? steps)

(reverse (car args))

(if (null? args)

(pc:melody-by-step starting-pitch steps pc (cons starting-pitch args))

(pc:melody-by-step (pc:relative starting-pitch (car steps) pc)

(cdr steps)

(cons (pc:relative starting-pitch (car steps) pc) (car args)))))))

;; generate a meldoy from a list of intervals

(define ivl:melody-by-ivl

(lambda (starting-pitch ivls . args)

(if (null? ivls)

(reverse (car args))

(if (null? args)

(ivl:melody-by-ivl starting-pitch ivls (cons starting-pitch args))

(ivl:melody-by-ivl (+ starting-pitch (car ivls)) (cdr ivls)

(cons (+ starting-pitch (car ivls)) (car args)))))))