;; aa-cell pitch class library
;; A collection of functions for working with pitch class 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-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)) 
     (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))))

;; 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 . dorian))
     (iii7 . (4 . dorian))
     (iv . (5 . lydian))
     (iv7 . (5 . lydian))
     (v . (7 . mixolydian))
     (v7 . (7 . mixolydian))
     (vi . (9 . dorian))
     (vi7 . (9 . dorian))
     (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 (fmod pitch 12) pc))
          #t
          #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 pc)
      (let loop ((inc 0))
         (cond ((pc:? (+ pitch inc) pc) (+ pitch inc))
               ((pc:? (- pitch inc) pc) (- pitch inc))
               ((< inc 7) (loop (+ inc 1)))
               (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 (fmod 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)
                         u
                         (- n 1)
                         (if (> (length p) 1) 
                             (cl:remove (fmod (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) (fmod value 12))
                 i
                 (loop (+ i 1) (cdr lst)))))))

;; retrograde list
(define retrograde reverse)

;; invert list paying no attention to key
(define 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 transpose
   (lambda (val lst)
      (map (lambda (i)
              (+ i val))
           lst))) 

;; expand/contract list by factor paying no attention to key
(define 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)))))))

;; quantize the values of lst to pc
(define pc:quantize-list
   (lambda (lst pc)
      (map (lambda (i)
              (pc:quantize i pc))
           lst)))

;; invert the values of lst quantizing to pc
(define pc:invert
   (lambda (lst pc . args)
      (if (null? args)
          (pc:quantize-list (invert lst) pc)
          (pc:quantize-list (invert lst (car args)) pc))))   

;; transpose the values of lst quantizing to pc
(define pc:transpose
   (lambda (val lst pc)
      (pc:quantize-list (transpose val lst) pc)))

;; expand/contract lst by factor quantizing to pc
(define pc:expand/contract
   (lambda (lst factor pc)
      (pc:quantize-list (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 (fmod (+ (cadr (assoc type *pc:chord->scale*)) root))
                (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) (fmod (+ 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 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 (fmod (+ (car l) root) 12) newlst))))
             (begin (print-notification "Chord type not found." chords) #f)))))