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

;;;;;Gradus - a Simple Music Learning program

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

This program should run on any complete implementation of Common Lisp.

Note that the default values given to *illegal-verticals*, *illegal-parallel-motions*,

*direct-fifths-and-octaves*, and *illegal-double-skips* below are just that -

default values. When the program runs with *auto-goals* set to t then the program

creates the values for these variables automatically as specified in my article

related to this file: "A Musical Learning Algorithm" in Computer Music Journal.

;;;the variables

;;;settings for Macintosh Common Lisp only (to prepare my preferred environment).

(progn

(setq *save-doc-strings* t)

(setq *arglist-on-space* t)

(setq *save-local-symbols* t)

(setq *print-case* :downcase)

(setq *paste-with-styles* ())

(setq *fasl-save-local-symbols* t)

(setq *save-definitions* t)

(setq *break-on-errors* ())

(setq *trace-print-length* 100)

(setq *trace-print-level* 20)

(setq *print-pretty* t))

(defvar *major-scale* '(36 38 40 41 43 45 47 48 50 52 53 55

57 59 60 62 64 65 67 69 71 72 74 76

77 79 81 83 84 86 88 89 91 93 95 96) "Major scale")

(defvar *illegal-verticals* '(0 1 2 5 6 10 11 13 14 17 18 22 23 25 26 29 30 34 35 -1 -2 -3 -4 -5 -6 -7 -8) "Illegal verticals")

(defvar *illegal-parallel-motions* '((7 7)(12 12)(19 19)(24 24)) "Illegal parallel motions")

(defvar *illegal-double-skips* '((3 3)(3 4)(3 -3)(3 -4)(-3 -3)(-3 -4)(-3 3)(-3 4)

(4 3)(4 4)(4 -3)(4 -4)(-4 -3)(-4 -4)(-4 3)(-4 4)) "Illegal double skips")

(defvar *direct-fifths-and-octaves* '((9 7)(8 7)(21 19)(20 19)) "Direct fifths and octaves")

(defvar *solution* () "Where the initial solution is stored")

(defvar *counterpoint* () "The resulting counterpoint is stored here.")

(defvar *save-voices* () "Pitches only of the resultant counterpoint are stored here.")

(defvar *rules* () "Where the program stores its rules")

(defvar *seed-note* 60 "The note which produces the possibilities for the opening note ")

(defvar *seed-notes* '(64 62 59 57 55 60) "Must start with a reasonable seed note for the program to work")

(defvar *backtrack* () "Sets the backtrack printout routine.")

(defvar *cantus-firmus* '(69 71 72 76 74 72 74 72 71 69) "The cantus firmus")

(defvar *new-line* () "Shere the new line is stored")

(defVar *rs* (make-random-state t) "Variable for storing the current random state.")

(defvar *save-rules* () "Variable for storing rules during the inference process.")

(defvar *print-state* t "Variable for setting whether or not the Listener window prints the various steps of composition.")

(defvar *auto-goals* () "Variable for having the program create its own goals.")

(defvar *models* () "Where the models for the goals are stored.")

(defvar *saved-templates* () "Where the templates for getting successful seeds are stored.")

(setq c1 36 d1 38 e1 40 f1 41 g1 43 a1 45 b1 47 c2 48 d2 50 e2 52 f2 53 g2 55 a2 57 b2 59 c3 60

d3 62 e3 64 f3 65 g3 67 a3 69 b3 71 c4 72 d4 74 e4 76 f4 77 g4 79 a4 81 b4 83 c5 84 d5 86

e5 88 f5 89 g5 91 a5 93 b5 95 c5 96)

(defvar *list-of-notes* '(c1 d1 e1 f1 g1 a1 b1 c2 d2 e2 f2 g2 a2 b2 c3 d3 e3 f3 g3 a3 b3 c4 d4 e4 f4 g4 a4 b4 c5 d5

e5 f5 g5 a5 b5 c5) "Notenames and registers for translating MIDI numbers into notenames.")

(defvar *look-ahead* () "Indicates whether the program has looked ahead or not.")

(defvar *temporary-rules* ())

(defvar *last-cantus-firmus* ())

(defvar *past-model-length* ())

the default:

(setq *cantus-firmus* '(69 71 72 76 74 72 74 72 71 69))

some other logical cantus firmus possibilities

(setq *cantus-firmus* '(69 71 69 72 71 74 72 71 69))

(setq *cantus-firmus* '(69 71 72 76 74 72 71 72 74 72))

(setq *cantus-firmus* '(69 71 72 71 72 74 72))

(setq *cantus-firmus* '(72 71 69 71 69 72 71 72))

(setq *cantus-firmus* '(69 71 72 69 71 72 74 72 76 74 72))

(setq *cantus-firmus* '(72 71 74 72 71 69 71 69))

example of a problem cantus firmus

(setq *cantus-firmus* '(72 71 69 71 72 76 74 72))

;;;the top-level

(defun gradus (&key (auto-goals *auto-goals*) ;;;decide autonomous goals

(print-state *print-state*) ;;;print out "working" + voices

(seed-note nil) ;;;decide new seed note

(cantus-firmus *cantus-firmus*)) ;;;new cantus firmus

"top-level function of the counterpoint program."

(unless (equal *last-cantus-firmus* *cantus-firmus*)

(progn

(setq *temporary-rules* ())(setq *last-cantus-firmus* *cantus-firmus*)))

(if seed-note (setq *seed-note* seed-note) ;;;create relevant seed-note

(let ((test (select-new-seed-note *cantus-firmus* *major-scale* *saved-templates*)))

(if test (setq *seed-note* test))))

(setq *auto-goals* auto-goals) ;;;create new goals

(setq *print-state* print-state)

(setq *cantus-firmus* cantus-firmus)

(if (null *auto-goals*)(set-default-goals))

(if *auto-goals* (progn (set-goals *models*)(setq *auto-goals* ())(setq *past-model-length* (length *models*))))

(if (not (equal (length *models*) *past-model-length*)) (set-goals *models*))

(setq *past-model-length* (length *models*))

(setq *new-line* ()) ;;;erase previous attempt

(setq *solution*

(create-new-line ;;;compose the new line

*cantus-firmus*

*major-scale*

(mix (create-choices *major-scale* *seed-note*)) nil)) ;;;mix the choices for first note

(setq *save-voices* (list (firstn (length *solution*) *cantus-firmus*)

*solution*)) ;;;show voices as lines

(setq *save-voices* (mapcar #'translate-into-pitchnames *save-voices*)) ;;;change to pitch names

(setq *counterpoint* (make-events (pair *save-voices*))) ;;;create the events for playing

(if (equal (length *cantus-firmus*)(length (second *save-voices*)))

(push (analyze-for-template *seed-note* *cantus-firmus* *major-scale*)

*saved-templates*)) ;;;add template if successful

*counterpoint*) ;;;return cpt for playing

(defun create-new-line (cantus-firmus scale choices last-notes &optional (length (length cantus-firmus)))

"creates a new line with the cantus firmus."

(if (stop-if-all-possibilities-are-nil *seed-note* *cantus-firmus* *rules*) ;;;stop if all seed notes fail

(format t "~A~&" "I can find no solution for this cantus firmus.")

(if (<= length 0) *new-line* ;;;if length is zero, end

(let ((test (evaluate-choices cantus-firmus choices last-notes))) ;;;evaluate the possibilities

(if (null test) ;;;if none are possible

(progn ;;;create a new rule to avoid in future

(if (null *look-ahead*)

(pushnew (create-rule cantus-firmus (append last-notes (list (first choices)))) *rules* :test #'equal)

(pushnew (create-rule cantus-firmus (append last-notes (list (first choices)))) *temporary-rules* :test #'equal))

(progn (setq *save-rules* *rules*) ;;;infer the strongest rule

(if (not (< (length *rules*)(length *save-rules*)))

(print-backtracking))) ;;;backtrack

(let ((new-last-notes (get-new-starting-point last-notes)))

(setf *new-line* (butlast *new-line* (- (length last-notes)(length new-last-notes))))

(create-new-line cantus-firmus

scale

(remove (my-last last-notes)

(mix (create-choices

*major-scale*

(if (null new-last-notes) *seed-note* (my-last new-last-notes)))))

new-last-notes

(+ length (- (length last-notes)(length new-last-notes))))))

(progn (setf *new-line* (append *new-line* (list test))) ;;;recurse if choice works

(if *print-state* (print-working cantus-firmus *new-line*))

(create-new-line cantus-firmus

scale

(mix (create-choices *major-scale* test))

(append last-notes (list test))

(1- length))))))))

(defun get-new-starting-point (last-notes)

"for backtracking - starts 2 earlier (may want to make this variable to get out of loops?) or nil"

(cond ((<= (length last-notes) 1) ())

(t (butlast last-notes 1))))

(defun evaluate-choices (cantus-firmus choices last-notes)

"runs the evaluate and look-ahead functions through the various choices."

(let ((correct-choices (evaluate cantus-firmus choices last-notes)))

(if correct-choices (setq *look-ahead* t)(setq *look-ahead* ()))

(if (> (length correct-choices) 0)

(look-ahead-for-best-choice cantus-firmus last-notes correct-choices)

(first correct-choices))))

(defun evaluate (cantus-firmus choices last-notes)

"evaluates the various choices for a next note based on the goals and current rules"

(let ((choice (first choices)))

(cond ((null choices)())

((and (not (consult-rules (create-rule cantus-firmus (append last-notes (list choice)))))

(not (test-for-vertical-dissonance (nth (length last-notes) cantus-firmus) choice))

(not (test-for-parallel-octaves-and-fifths (firstn (1+ (length last-notes)) cantus-firmus)

choice last-notes))

(not (test-for-leaps (append last-notes (list choice))))

(not (test-for-simultaneous-leaps (firstn (1+ (length last-notes)) cantus-firmus)

choice last-notes))

(not (test-for-direct-fifths (firstn (1+ (length last-notes)) cantus-firmus)

choice last-notes))

(not (test-for-consecutive-motions (firstn (1+ (length last-notes)) cantus-firmus)

choice last-notes)))

(cons choice (evaluate cantus-firmus (rest choices) last-notes)))

(t (evaluate cantus-firmus (rest choices) last-notes)))))

(defun create-choices (scale last-choice)

"creates four possible choices - seconds and thirds - from a previous pitch choice."

(list (choose-from-scale last-choice 1 scale)

(choose-from-scale last-choice 3 scale)

(choose-from-scale last-choice -1 scale)

(choose-from-scale last-choice -3 scale)))

(defun choose-from-scale (current-note interval-class scale)

"gets the appropriate pitch from the current scale based on the interval class."

(if (plusp interval-class)

(nth (get-diatonic-interval interval-class) (member current-note scale))

(nth (abs (get-diatonic-interval interval-class)) (member current-note (reverse scale)))))

(defun get-diatonic-interval (interval-class)

"translates interval-classes into diatonic-interval classes."

(cond ((equal interval-class 1) 1)

((equal interval-class 2) 1)

((equal interval-class 3) 2)

((equal interval-class 4) 2)

((equal interval-class -1) -1)

((equal interval-class -2) -1)

((equal interval-class -3) -2)

((equal interval-class -4) -2)

(t 1)))

;;;testers

(defun consult-rules (rule)

"Calling (consult-rules (-9 (2 -1 -1) (-1 2 -2)))

consult-rules returned nil"

(or (member rule *rules* :test #'equal)

(member rule *temporary-rules* :test #'equal)))

(defun create-rule (cantus-firmus new-notes)

"creates rules for the *rules* variable"

(let ((the-list (the-last 4 new-notes)))

(create-interval-rule

(list (the-last (length the-list)

(butlast cantus-firmus (- (length cantus-firmus)(length new-notes)))) the-list))))

(defun test-for-vertical-dissonance (cantus-firmus-note choice)

"tests to ensure vertical dissonance"

(if (member (- cantus-firmus-note choice) *illegal-verticals*) choice))

(defun test-for-parallel-octaves-and-fifths (cantus-firmus choice last-notes)

"tests for parallel octaves and fifths."

(let ((cantus-firmus-to-here (firstn (1+ (length last-notes)) cantus-firmus)))

(cond ((or (not (>= (length cantus-firmus-to-here) 2))(not (>= (length last-notes) 1))) ())

((member (list (abs (- (second-to-last cantus-firmus-to-here)(my-last last-notes)))

(abs (- (my-last cantus-firmus-to-here) choice)))

*illegal-parallel-motions* :test #'equal) t)

(t nil))))

(defun test-for-leaps (extended-last-notes)

"tests for leaps and avoids two in row and ensures that leaps are followed by contrary motion steps."

(cond ((not (>= (length extended-last-notes) 3)) ())

((member (list (- (second-to-last extended-last-notes)(my-last extended-last-notes))

(- (third-to-last extended-last-notes)(second-to-last extended-last-notes)))

*illegal-double-skips* :test #'equal) t)

((and (> (abs (- (third-to-last extended-last-notes)(second-to-last extended-last-notes))) 2)

(not (opposite-sign (list (- (second-to-last extended-last-notes)(my-last extended-last-notes))

(- (third-to-last extended-last-notes)(second-to-last extended-last-notes))))))

(t ())))

(defun test-for-simultaneous-leaps (cantus-firmus choice last-notes)

"tests for the presence of simultaneous leaps."

(let ((cantus-firmus-to-here (firstn (1+ (length last-notes)) cantus-firmus)))

(cond ((or (not (>= (length cantus-firmus-to-here) 2))(not (>= (length last-notes) 1))) ())

((and (skipp (the-last 2 cantus-firmus-to-here))(skipp (the-last 2 (append last-notes (list choice))))) t)

(t ()))))

(defun test-for-direct-fifths (cantus-firmus choice last-notes)

"tests for direct fifths between the two lines."

(let ((cantus-firmus-to-here (firstn (1+ (length last-notes)) cantus-firmus)))

(cond ((or (not (>= (length cantus-firmus-to-here) 2))(not (>= (length last-notes) 1))) ())

((member (get-verticals (the-last 2 cantus-firmus-to-here)(the-last 2 (append last-notes (list choice))))

*direct-fifths-and-octaves* :test #'equal) t)

(t ()))))

(defun test-for-consecutive-motions (cantus-firmus choice last-notes)

"tests to see if there are more than two consecutive save-direction motions."

(let ((cantus-firmus-to-here (firstn (1+ (length last-notes)) cantus-firmus)))

(cond ((or (not (> (length cantus-firmus-to-here) 3))(not (> (length last-notes) 2))) ())

((let ((last-four-cf (the-last 4 cantus-firmus-to-here))

(last-four-newline (the-last 4 (append last-notes (list choice)))))

(not (or (opposite-sign (list (first (get-intervals (firstn 2 last-four-cf)))

(first (get-intervals (firstn 2 last-four-newline)))))

(opposite-sign (list (first (get-intervals (firstn 2 (rest last-four-cf))))

(first (get-intervals (firstn 2 (rest last-four-newline))))))

(opposite-sign (list (first (get-intervals (the-last 2 last-four-cf)))

(first (get-intervals (the-last 2 last-four-newline)))))))) t)

(t ()))))

(defun create-interval-rule (rule)

"Creates the interval rule as in (-7 (2 2 2)(-1 1 2))."

(list (first (find-scale-intervals (list (first (first rule))

(first (second rule)))

*major-scale*))

(find-scale-intervals (first rule) *major-scale*)

(find-scale-intervals (second rule) *major-scale*)))

(defun reduce-to-within-octave (interval)

"Reduces diatonic intervals to within the octave."

(cond ((and (> (abs interval) 7)(minusp interval))

(reduce-to-within-octave (+ interval 7)))

((> (abs interval) 7)(- interval 7))

((zerop interval) -7)

(t interval)))

(defun find-scale-intervals (notes scale)

"Returns the diatonic intervals between the notes according to the scale."

(cond ((null (rest notes))())

((null (second notes))

(cons nil (find-scale-intervals (rest notes) scale)))

(t (cons (let ((first-note-test (member (first notes) scale :test #'equal))

(second-note-test (member (second notes) scale :test #'equal)))

(if (< (first notes)(second notes))

(length (butlast first-note-test (length second-note-test)))

(- (length (butlast second-note-test (length first-note-test))))))

(find-scale-intervals (rest notes) scale)))))

;;;looking ahead

(defun look-ahead-for-best-choice (cantus-firmus last-notes correct-choices)

"looks ahead for the best choice"

(cond ((null correct-choices) ())

((not (look-ahead 1

cantus-firmus

(append last-notes (list (first correct-choices)))

(create-rule cantus-firmus (append last-notes (list (first correct-choices))))

*rules*))

(first correct-choices))

(t (look-ahead-for-best-choice cantus-firmus last-notes (rest correct-choices)))))

(defun look-ahead (amount cantus-firmus last-notes rule rules)

"the top-level function for looking ahead"

(match-rules-freely

(reduce-rule (make-freer-rule amount (find-scale-intervals (create-relevant-cf-notes last-notes cantus-firmus) *major-scale*) rule))

rules))

(defun create-relevant-cf-notes (last-notes cantus-firmus)

"creates the set of forward reaching cf notes"

(firstn 2 (nthcdr (1- (length last-notes)) cantus-firmus)))

(defun reduce-rule (rule)

"reduces the front-end of the look-ahead rule"

(if (<= (length (second rule)) 3) rule

(let ((amount (- (length (second rule)) 3)))

(cons (+ (first rule)(- (first (second rule)))(first (third rule)))

(mapcar #'(lambda (x)(nthcdr amount x)) (rest rule))))))

(defun make-freer-rule (amount cf-notes rule)

"adds the appropriate number of nils to the new line for look-ahead matching"

(if (zerop amount) rule

(make-freer-rule (1- amount)

(rest cf-notes)

(list (first rule)

(append (second rule)(list (first cf-notes)))

(append (third rule)(list nil))))))

(defun match-rules-freely (rule rules)

"runs the match-rule function through the rules"

(cond ((null rules)())

((and (equal (first rule)(first (first rules)))

(match-interval-rule (rest rule)(rest (first rules)))) t)

((and (equal (first rule)(first (first rules)))

(equal (length (second rule))(length (second (first rules))))

(match-rule rule (first rules))) t)

(t (match-rules-freely rule (rest rules)))))

(defun match-interval-rule (rule-for-matching rule)

"matches the freer rule to the rule from *rules*"

(cond ((and (null (first rule-for-matching))(null (first rule))) t)

((or (and (equal (very-first rule-for-matching)(very-first rule))

(equal (very-second rule-for-matching)(very-second rule)))

(and (equal (very-first rule-for-matching)(very-first rule))

(null (very-second rule-for-matching))))

(match-interval-rule (mapcar #'rest rule-for-matching) (mapcar #'rest rule)))

(t nil)))

(defun match-rule (rule-for-matching rule)

"matches the freer rule to the rule from *rules*"

(cond ((and (null (first (rest rule-for-matching)))(null (first (rest rule)))) t)

((or (and (equal (very-first (rest rule-for-matching))(very-first (rest rule)))

(equal (very-second (rest rule-for-matching))(very-second (rest rule))))

(and (equal (very-first (rest rule-for-matching))(very-first (rest rule)))

(null (very-second (rest rule-for-matching)))))

(match-rule (cons (first rule-for-matching)(mapcar #'rest (rest rule-for-matching)))

(cons (first rule)(mapcar #'rest (rest rule)))))

(t nil)))

(defun replenish-seed-notes ()

"replenishes the seednotes when when they have all been used."

(setq *seed-notes* '(60 65 64 62 59 57 55 53)))

;;;;setting goals automatically

(setq *models* '

(((72 71 74 72 71 69 67 69) (64 67 65 64 62 65 64 60))

((72 71 74 72 71 69 67 69) (57 55 53 57 55 53 55 53))

((72 71 74 72 71 69 67 69) (57 55 53 52 50 53 52 48))

((72 71 74 72 71 69 67 69) (64 67 65 64 67 65 64 60))

((69 71 72 69 71 72 74 77 76 74 72) (57 55 52 53 55 57 55 57 55 59 57))

((69 71 72 69 71 72 74 77 76 74 72) (57 55 52 53 55 57 55 53 55 53 52))

((69 71 72 69 71 72 74 77 76 74 72) (57 55 52 53 55 57 55 53 55 59 57))

((69 71 72 69 71 72 74 77 76 74 72) (57 55 52 53 55 57 55 57 60 59 60))

((69 71 72 69 71 72 74 77 76 74 72) (57 55 52 53 55 57 55 57 60 59 57))

((72 71 69 67 69 72 71 72) (64 62 60 64 62 60 62 64))

((72 71 69 67 69 72 71 72) (64 62 65 64 65 64 67 65))

((72 71 69 67 69 72 71 72) (57 59 60 64 62 60 62 64))

((72 71 69 67 69 72 71 72) (57 55 53 55 53 52 50 48))

((72 71 69 67 69 72 71 72) (64 62 65 64 65 64 62 64))

((72 71 69 67 69 72 71 72) (64 67 65 64 62 60 62 64))

((72 71 69 67 69 72 71 72) (57 59 60 64 62 64 67 65))

((72 71 69 67 69 72 71 72) (57 55 53 55 53 52 55 53))

((72 71 69 67 69 72 71 72) (64 62 65 64 62 60 62 60))

((72 71 69 67 69 72 71 72) (64 62 60 64 62 64 67 65))

((72 71 69 67 69 72 71 72) (64 67 65 64 62 64 67 65))

((72 71 69 67 69 72 71 72) (57 55 53 55 53 52 50 52))

((72 71 69 67 69 72 71 72) (64 67 65 64 62 64 62 60))

((72 71 69 67 69 72 71 72) (64 67 65 64 62 60 62 60))

((72 71 69 67 69 72 71 72) (64 62 60 64 62 64 62 60))

((69 71 72 76 74 72 71 72 74 72) (57 55 57 55 53 57 55 57 55 57))

((69 71 72 76 74 72 71 72 74 72) (57 55 57 55 53 57 55 52 53 57))

((69 71 72 76 74 72 71 72 74 72) (57 55 57 55 53 57 55 53 50 52))

((69 71 72 76 74 72 71 72 74 72) (57 55 57 55 59 57 59 57 59 57))

((69 71 72 76 74 72 71 72 74 72) (57 55 57 55 59 57 59 57 55 52))

((69 71 72 76 74 72 71 72 74 72) (57 55 53 52 53 52 50 48 47 45))

((69 71 72 76 74 72 71 72 74 72) (57 55 57 55 53 52 55 53 50 52))

((69 71 69 72 71 74 72 71 69) (57 55 53 52 55 53 57 55 57))

((69 71 69 72 71 74 72 71 69) (57 55 53 52 55 53 57 55 53))

((69 71 69 72 71 74 72 71 69) (57 55 53 52 55 53 52 50 53))

((69 71 72 76 74 72 74 72 71 69) (57 55 53 55 53 57 55 57 59 60))

((69 71 72 76 74 72 74 72 71 69) (57 55 57 55 53 52 50 52 50 53))

((69 71 72 76 74 72 74 72 71 69) (57 55 53 55 53 57 55 57 59 62))

((69 71 72 76 74 72 74 72 71 69) (57 55 53 52 53 52 53 57 55 57))

((69 71 72 76 74 72 74 72 71 69) (57 55 53 55 59 57 55 57 59 62))

((69 71 72 76 74 72 74 72 71 69) (57 55 53 52 53 52 50 52 55 53))

((69 71 72 76 74 72 74 72 71 69) (57 55 57 55 53 52 50 52 55 53))

((69 71 72 76 74 72 74 72 71 69) (57 55 53 52 53 57 55 57 55 57))

((69 71 72 76 74 72 74 72 71 69) (57 55 53 55 53 57 55 57 55 53))

((69 71 72 76 74 72 74 72 71 69) (57 55 53 55 59 57 55 57 55 53))

((69 71 72 76 74 72 74 72 71 69) (57 55 57 55 59 57 59 60 62 65))

((69 71 72 76 74 72 74 72 71 69) (57 55 57 55 59 57 59 60 62 60))

((69 71 69 72 71 74 72 71 69) (57 55 53 52 55 53 52 55 53))

((69 71 72 76 74 72 71 72 74 72) (57 55 57 55 59 57 55 53 50 52))

((69 71 72 74 71 72 74 72) (57 55 57 53 55 53 50 52))

((69 71 72 69 71 72 74 77 76 74 72) (57 55 52 53 55 57 55 53 55 53 57))))

(defun set-goals (models)

"Sets the goals for the gradus program."

(setf *illegal-verticals* (get-illegal-verticals models))

(setf *illegal-parallel-motions* (find-illegal-parallels models))

(setf *direct-fifths-and-octaves* (find-illegal-parallels models))

(setf *illegal-double-skips* (possible-combinations '(3 4 -3 -4))))

(defun get-illegal-verticals (models)

"Returns all of the vertical intervals NOT in the models."

(get-complement (get-the-verticals models)))

(defun get-complement (verticals &optional (number 0))

"Incrementally returns all of the intervals not in the verticals arg."

(cond ((null verticals)())

((member number verticals)

(get-complement (rest verticals)(1+ number)))

(t (cons number (get-complement verticals (1+ number))))))

(defun get-the-verticals (models)

"Collects the vertical intervals from the models used."

(my-sort #'<

(remove-duplicates

(project

(let ((voiced-music (pair (make-voices models))))

(loop for pair in voiced-music

collect (- (first pair) (second pair))))) :test #'equal)))

(defun make-voices (models)

"Makes lists of the cantus firmus and accompanying line pitches."

(list (apply #'append (mapcar #'first models))(apply #'append (mapcar #'second models))))

(defun project (numbers)

"(project '(7))

(7 19 31)"

(if (null numbers)()

(append (pro (first numbers))

(project (Rest numbers)))))

(defun pro (number)

"Calling (pro 7)

pro returned (7 19 31)"

(if (> number 12)

(list (- number 12) number (+ number 12))

(list number (+ number 12)(+ number 24))))

(defun my-sort (function lists)

"(my-sort '< '(3 4 2 6 1 4))

>> (1 2 3 4 4 6)"

(loop for item in (sort (loop for x in lists

collect (list x)) function :key #'car)

collect (first item)))

(defun find-illegal-parallels (models)

"Returns the non-used parallels in the models which are assumed to be illegal."

(let* ((illegal-verticals (get-illegal-verticals models)) ;;;good!

(legal-verticals (remove-illegal-verticals illegal-verticals (find-all-possible-motions 24)))

(model-verticals (find-legals models)))

(remove-legal-motions model-verticals legal-verticals)))

(defun remove-legal-motions (legal-motions motions)

"Removes the legal motions from the motions arg."

(cond ((null legal-motions) motions)

((member (first legal-motions) motions :test #'equal)

(progn (setf motions (remove (first legal-motions) motions :test #'equal))

(remove-legal-motions (rest legal-motions) motions)))

(t (remove-legal-motions (rest legal-motions) motions))))

(defun find-legals (models)

"Collects the legal motions in its arg."

(if (null models)()

(append (find-the-legals (pair (first models)))

(find-legals (rest models)))))

(defun find-the-legals (paired-model)

"Discovers the legal motions in its arg."

(if (null (rest paired-model))()

(cons (list (- (first (first paired-model))(second (first paired-model)))

(- (first (second paired-model))(second (second paired-model))))

(find-the-legals (rest paired-model)))))

(defun remove-illegal-verticals (illegal-verticals all-verticals)

"Removes the illegal verticals in its second arg."

(cond ((null all-verticals) ())

((anyp illegal-verticals (first all-verticals))

(remove-illegal-verticals illegal-verticals (rest all-verticals)))

(t (cons (first all-verticals)

(remove-illegal-verticals illegal-verticals (rest all-verticals))))))

(defun find-all-possible-motions (extent &optional (value 0)(save-extent extent))

"Returns all possible motions to its extent arg."

(if (zerop extent)()

(append (find-motions extent save-extent)

(find-all-possible-motions (1- extent) value save-extent))))

(defun find-motions (extent value)

"Sub-function of find-all-possible-motions."

(if (zerop value)()

(cons (list extent value)

(find-motions extent (1- value)))))

(defun anyp (find-list target-list)

"(anyp '(a b) '(a b c d))

>> A"

(loop for find in find-list

when (member find target-list :test #'equal)

return find))

(defun possible-combinations (list &optional (save-list list))

"Returns all possible combinations of its list arg."

(if (null list)()

(append (combinations (first list) save-list)

(possible-combinations (rest list) save-list))))

(defun combinations (object list)

"A sub-function of possible-combinations."

(if (null list)()

(cons (list object (first list))

(combinations object (rest list)))))

;;;creating the templates

(defun analyze-for-template (seed-note cantus-firmus scale)

"Returns the complete template (seed interval and map) for saving."

(list (first (find-scale-intervals (list (first cantus-firmus) seed-note) scale))

(get-map cantus-firmus scale)))

(defun get-map (cantus-firmus scale)

"Returns the map part of the template."

(list (get-tessitura cantus-firmus scale)

(first (find-scale-intervals (list (first cantus-firmus)(my-last cantus-firmus)) scale))))

(defun get-tessitura (cantus-firmus scale)

"Gets the tessitura or highest/lowest interval of a note list."

(let ((up

(abs (first (find-scale-intervals (list (first cantus-firmus)(apply #'max cantus-firmus)) scale))))

(down

(abs (first (find-scale-intervals (list (first cantus-firmus)(apply #'min cantus-firmus)) scale)))))

(if (> up down) up (- down))))

(defun select-new-seed-note (cantus-firmus scale saved-templates)

"Select a logical new seed note."

(get-diatonic-note (first cantus-firmus)

(first

(second

(first

(sortcar #'>

(return-counts (collect-all (get-map cantus-firmus scale) saved-templates))))))

scale))

(defun collect-all (map saved-templates)

"Collects all of the occurances of each member of its arg."

(cond ((null saved-templates)())

((equal map (second (first saved-templates)))

(cons (first saved-templates)

(collect-all map (rest saved-templates))))

(t (collect-all map (rest saved-templates)))))

(defun return-counts (templates)

"Simply adds the count of occurances to the beginning of each member of its arg."

(if (null templates)()

(cons (list (count (first templates) templates :test #'equal)(first templates))

(return-counts (remove (first templates) templates :test #'equal)))))

(defun sortcar (function lists)

"non-destructive sort-by-first function"

(let ((first-lists (sort (loop for item in lists

collect (first item)) function)))

(loop for item in first-lists

collect (assoc item lists)

do (setf first-lists (rest first-lists))

do (setf lists (remove (assoc item lists) lists :test 'equal :count 1)))))

(defun get-diatonic-note (current-note interval scale)

"a simple variant of choose-from-scale which uses a diatonic interval as its second arg."

(cond ((null interval)())

((plusp interval)(nth interval (member current-note scale)))

(t (nth (abs interval) (member current-note (reverse scale))))))

;;;utilities

(defun make-events (pitch-groupings &optional (ontime 0))

"makes events out of the pairs of pitches in its arg."

(if (null pitch-groupings) ()

(append (list (make-event ontime (first (first pitch-groupings)) 1)

(make-event ontime (second (first pitch-groupings)) 2))

(make-events (rest pitch-groupings)(+ ontime 1000)))))

(defun make-event (ontime pitch channel)

"creates an event"

(list ontime

(if (symbolp pitch) (eval pitch) pitch)

1000

channel

90))

(defun choose-one (list)

"chooses one its arg randomly."

(nth (random (length list) *rs*) list))

(defun mix (list)

"Mixes its arg randomly"

(let ((choice ()))

(loop until (null list)

do (setf choice (choose-one list))

collect choice

do (setf list (remove choice list :count 1)))))

(defun my-last (list)

"returns th atom last of the list."

(first (last list)))

(defun firstn (number list)

"returns the first n of is list arg."

(if (< (length list) number)(firstn (1- number) list)

(butlast list (- (length list) number))))

(defun skipp (notes)

"returns true if its two-number arg is a skip."

(if (> (abs (- (second notes)(first notes))) 2) t))

(defun get-verticals (cantus-firmus new-line)

"returns the intervals between two lines of counterpoint."

(if (null cantus-firmus)()

(cons (- (first cantus-firmus)(first new-line))

(get-verticals (rest cantus-firmus)(rest new-line)))))

(defun get-intervals (notes)

"returns a list of intervals one short of its pitch-list arg."

(if (null (rest notes))()

(cons (- (second notes)(first notes))

(get-intervals (rest notes)))))

(defun opposite-sign (numbers)

"returns t if the two numbers have opposite signs."

(if (or (and (minusp (first numbers))(plusp (second numbers)))

(and (plusp (first numbers))(minusp (second numbers)))) t))

(defun second-to-last (list)

"returns the second to last of the list arg."

(my-last (butlast list)))

(defun third-to-last (list)

"returns the third to last of the list arg."

(nth (- (length list) 3) (butlast list)))

(defun pair (voices)

"? (pair '((1 2 3)(4 5 6)))

((1 4) (2 5) (3 6))"

(if (null (first voices))()

(cons (list (first (first voices))(first (second voices)))

(pair (list (rest (first voices))(rest (second voices)))))))

(defun print-backtracking ()

"simple printing function for backtracking"

(format t "~&~A~&~A~&~A~&" "backtracking.....there are now" (length *rules*) "rules."))

(defun print-working (cantus-firmus last-notes)

"simple printing function for continuing to compose"

(format t "~&~A~&~A~&" "working....." (list (translate-into-pitchnames cantus-firmus)(translate-into-pitchnames last-notes))))

(defun the-last (n list)

(if (< (length list) n) list

(nthcdr (- (length list) n) list)))

(defun very-first (list)

"(very-first '((1 4) (2 5) (3 6)))

(first (first list)))

(defun very-second (list)

"(very-second '((1 4) (2 5) (3 6)))

(first (second list)))

(defun set-default-goals ()

"Sets the default goals for the program."

(setq *illegal-verticals* '(0 1 2 5 6 10 11 13 14 17 18 22 23 25 26 29 30 34 35 -1 -2 -3 -4 -5 -6 -7 -8))

(setq *illegal-parallel-motions* '((7 7)(12 12)(19 19)(24 24)))

(setq *illegal-double-skips* '((3 3)(3 4)(3 -3)(3 -4)(-3 -3)(-3 -4)(-3 3)(-3 4)

(4 3)(4 4)(4 -3)(4 -4)(-4 -3)(-4 -4)(-4 3)(-4 4)))

(setq *direct-fifths-and-octaves* '((9 7)(8 7)(21 19)(20 19))))

(defun stop-if-all-possibilities-are-nil (seed-note cantus-firmus rules)

"For stopping if no solution exists."

(check-for-nils

(mapcar #'(lambda (x)

(reduce-to-within-octave

(first (find-scale-intervals (list (first cantus-firmus) x)

*major-scale*))))

(create-choices *major-scale* seed-note)) rules))

(defun check-for-nils (choices rules)

"checking to see if all possible first notes produce rule-conflicting problems."

(cond ((null choices) t)

((member (list (first choices)

nil nil) rules :test #'equal)

(check-for-nils (rest choices) rules))

(t nil)))

(defun translate-into-pitchnames (list-of-midi-note-numbers)

"Used to translate MIDI note numbers into note names."

(if (null list-of-midi-note-numbers)()

(cons (nth (position (first list-of-midi-note-numbers) *major-scale*) *list-of-notes*)

(translate-into-pitchnames (rest list-of-midi-note-numbers)))))

(defun translate-rule-into-pitches (first-note rule)

"Translates rules into more readable pitch names."

(list (translate-notes first-note (second rule))

(translate-notes (get-diatonic-note first-note (first rule) *major-scale*)(third rule))))

(defun translate-notes (first-note intervals)

"Translates interval lists into note names for readability."

(if (null intervals)(translate-into-pitchnames (list first-note))

(let ((test (get-diatonic-note first-note (first intervals) *major-scale*)))

(append (translate-into-pitchnames (list first-note))

(translate-notes test (rest intervals))))))

(defun evaluate-pitch-names (voices)

(mapcar #'(lambda (x)(mapcar #'eval x)) voices))

A Canon Maker....

(setq *illegal-verticals*

'(0 1 2 5 6 7 10 11 13 14 17 18 19 22 23 25 26 29 30 34 35 -1 -2 -3 -4 -5 -6 -7 -8))

(setq *cantus-firmus* '(69 71 72 76 74 72 71))

(defun create-canon ()

(setq *seed-note* (- (my-last *cantus-firmus*) 12))

(gradus)

(setq *save-voices* (evaluate-pitch-names *save-voices*))

(let* ((theme (append *cantus-firmus* (mapcar #'(lambda (x)(+ x 12))(second *save-voices*))))

(lower-voice (mapcar #'(lambda (x)(- x 12)) theme)))

(make-events

(pair (list (append theme theme theme (make-list (length *cantus-firmus*) :initial-element 0))

(append (make-list (length *cantus-firmus*) :initial-element 0) lower-voice lower-voice lower-voice))))))

A more contemporary example

(setq *models* '

(((72 71 74 72 71 69 67 69)

(71 69 67 65 69 67 65 62))

((72 71 74 72 71 69 67 69)

(65 64 60 62 64 67 65 67))

((69 71 69 72 71 74 72 71 69)

(62 64 67 65 64 60 62 64 62))

))

(setq *seed-notes* '(67 64 59 57 55 62))

(setq *cantus-firmus* '(72 71 69 67 69 72 71 72))

(setq *auto-goals* nil)

(setq *illegal-double-skips* '())

(setq *illegal-parallel-motions* '())

(setq *illegal-verticals* '())

(setq *direct-fifths-and-octaves* '())

(setq *auto-goals* t)