;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File:             tonal-algo-example.lsp
;;;
;;; Class Hierarchy:  None
;;;
;;; Version:          1.0
;;;
;;; Project:          slippery chicken (algorithmic composition)
;;;
;;; Purpose:          Lisp example code to accompany tonal.html
;;;
;;; Author:           Sean Reed
;;;
;;; Creation date:    1st October 2012
;;;
;;; $$ Last modified: 22:40:30 Fri May 17 2013 BST
;;;
;;; SVN ID: $Id: tonal-algo-example.lsp 3538 2013-05-18 08:29:15Z medward2 $
;;;
;;; ****
;;; Licence:          Copyright (c) 2012 Michael Edwards
;;;
;;;                   This file is part of slippery-chicken
;;;
;;;                   slippery-chicken is free software; you can redistribute it
;;;                   and/or modify it under the terms of the GNU General
;;;                   Public License as published by the Free Software
;;;                   Foundation; either version 3 of the License, or (at your
;;;                   option) any later version.
;;;
;;;                   slippery-chicken is distributed in the hope that it will
;;;                   be useful, but WITHOUT ANY WARRANTY; without even the
;;;                   implied warranty of MERCHANTABILITY or FITNESS FOR A
;;;                   PARTICULAR PURPOSE.  See the GNU General Public License
;;;                   for more details.
;;;
;;;                   You should have received a copy of the GNU General Public
;;;                   License along with slippery-chicken; if not, write to the
;;;                   Free Software Foundation, Inc., 59 Temple Place, Suite
;;;                   330, Boston, MA 02111-1307 USA
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package :sc)
(in-scale :chromatic)

;; The basis for the rthm-seqs is derived from the method classical
;; improvisation taught to the composer by Volkhardt Preuss at the Hochschule
;; fuer Musik und Theater Hamburg in the late 1990s.

;; This function collects the positions of a list of items within a larger set
;; of items. It is used to convert note-name symbols to numeric
;; pitch-seqs. This is MUCH easier, as it prevents the user from having to
;; count each desired pitch within the given subset in order to get the
;; pitch-seq number, and prevents resulting errors. All note-names in the
;; pitch-list must be present in the set.
(defun pitches-to-pseq (pitch-list set)
  (let* (positions lowest pseq)
    (setf positions (mapcar #'(lambda (x) (position x set)) pitch-list))
    (setf lowest (1- (first (sort (copy-list positions) #'<))))
    (setf pseq (mapcar #'(lambda (x) (- x lowest)) positions))
    pseq))

(let* ((num-seqs 29)
       ;; (num-seqs 129) ; This is the number of sequences prior to the
                                        ; coda. If the sequence
                                        ; generated by the
                                        ; l-for-lookup object does not
                                        ; end in a perfect cadence,
                                        ; the coda variable sees to it
                                        ; that one is added at the
                                        ; very end.
       ;; The two sets serve as the core sets for major and minor, and will be
       ;; transposed in the set-palette below. Both spellings of the same
       ;; enharmonic pitch (such as fs4/gf4) are often included, as these are
       ;; the pitches passed to the pitches-to-pseq function. In all actuality,
       ;; these could probably be reduced to just one large chromatic set.
       (core-set-maj '(g2 a2 bf2 b2 c3 d3 ef3 e3 f3 g3 a3 b3 c4 cs4 d4 ef4 e4
                       f4 fs4 gf4 g4 gs4 af4 a4 bf4 b4 c5 d5 e5 f5 fs5 g5 b5
                       c6))
       (core-set-min '(g2 af2 bf2 c3 ef3 f3 fs3 g3 af3 bf3 b3 c4 d4 ef4 e4 f4
                       fs4 gf4 g4 af4 a4 bf4 b4 c5 ef5 e5 f5))
       ;; This is the set-palette. Its IDs are strings consisting of a
       ;; pitch-class interval (0=C to 11=B) and the suffix MAJ or MIN. The
       ;; "MAJ" and "MIN" are important and are accessed below.
       (sp 
        (loop for i from 0 to 11
           if (= i 0)
           collect (list "0-MAJ" (list core-set-maj))
           and collect (list "0-MIN" (list core-set-min))
           else 
           collect (list (format nil "~a-MAJ" i)
                         (list "0-MAJ" ':transposition i))
           and collect (list (format nil "~a-MIN" i)
                             (list "0-MIN" ':transposition i))))
       ;; These are the rules for generating the sequence of patterns. There
       ;; are four pattern types used here: "fauxbourdon" (falling 6/3 chords
       ;; with 7-6 suspensions), "ruggiero" (dominant-tonic cadences), "sekund"
       ;; (4/2 chords serving as applied dominants), and "pedal" (transition
       ;; from tonic to subdominant over the tonic pitch in the bass). More of
       ;; these models can be added easily by the user (though a number of
       ;; variables must be given additional items in their lists if this is
       ;; done). The l-for-lookup object here just defines which pattern types
       ;; can progress to which. Each different type is given a letter and the
       ;; suffix of either "maj" or "min" to show the modality it occurs in,
       ;; which will be used to choose the appropriate set later. Each pattern
       ;; type may have more than one specific spelling, as defined in the
       ;; combos-al variable below.
       (seq-rules 
        (make-l-for-lookup 'seq-rules
                           nil
                           '((fauxbourdon-a-maj 
                              (ruggiero-a-maj ruggiero-b-maj
                                ruggiero-b-maj-to-min ruggiero-c-maj))
                             (fauxbourdon-a-min 
                              (ruggiero-a-min ruggiero-d-min-to-maj))
                             (ruggiero-a-maj 
                              (fauxbourdon-a-maj sekund-a-maj ped-a-maj))
                             (ruggiero-a-min 
                              (fauxbourdon-a-min sekund-a-min))
                             (ruggiero-b-maj 
                              (fauxbourdon-a-maj sekund-a-maj ped-a-maj))
                             (ruggiero-b-maj-to-min 
                              (fauxbourdon-a-min sekund-a-min))
                             (ruggiero-c-maj 
                              (fauxbourdon-a-maj sekund-a-maj ped-a-maj))
                             (ruggiero-d-min-to-maj 
                              (fauxbourdon-a-maj sekund-a-maj ped-a-maj))
                             (ruggiero-e-maj 
                              (fauxbourdon-a-maj sekund-a-maj ped-a-maj))
                             (sekund-a-maj 
                              (ruggiero-e-maj))
                             (sekund-a-min 
                              (ruggiero-a-min ruggiero-d-min-to-maj))
                             (ped-a-maj 
                              (sekund-a-maj)))))
       ;; This is the sequence then, using get-linear-sequence, essentially
       ;; like a markov kind of function.
       (seq-seq (get-linear-sequence seq-rules 'fauxbourdon-a-maj num-seqs))
       ;; This little loop and the variable afterwards ensure that the last
       ;; item in the sequence is a V-I cadence.
       (coda
        (loop
           with l = (first (last seq-seq))
           until (equalp (subseq (format nil "~a" l) 0 3)
                         "RUG")
           do
             (setf l (first (last (get-linear-sequence seq-rules l 2))))
           collect l))
       (seq-seq (append seq-seq coda))
       ;; These are the transposition rules. Each pattern type must have
       ;; one. Each 2-item list associated with a pattern type indicates the
       ;; number of semitones by which the pattern modulates and the modality
       ;; (major or minor) it ends in. These are used to create a list of
       ;; "transposition changes" below, which is essential for getting all the
       ;; transpositions of the individual rthm-seqs right.
       (transposition-rules-al 
        (make-assoc-list 'transposition-rules
                         '((fauxbourdon-a-maj (0 maj))
                           (fauxbourdon-a-min (0 min))
                           (ruggiero-a-maj (0 maj))
                           (ruggiero-a-min (0 min))
                           (ruggiero-b-maj (3 maj))
                           (ruggiero-b-maj-to-min (3 min))
                           (ruggiero-c-maj (-3 maj))
                           (ruggiero-d-min-to-maj (0 maj))
                           (ruggiero-e-maj (0 maj))
                           (sekund-a-maj (0 maj))
                           (sekund-a-min (0 min))
                           (ped-a-maj (0 maj)))))
       ;; This creates a list of two-item lists from the transposition
       ;; rules. These are then accessed in assembling the set-map as well as
       ;; in transposing the set-limits-high and -low so that the
       ;; transpositions allow the patterns to keep the exact same
       ;; voice-leading (relative pitches).
       (transpositions-changes 
        (let ((n 0)
              rule)
          (loop for seq in (subseq seq-seq 0 (1- (length seq-seq)))
             do (setf rule (get-data-data seq transposition-rules-al))
             collect (list
                      (setf n (mod (+ n (first rule)) 12))
                      (second rule))))) 
       ;; We have to add '(0 MAJ) to the beginning of the list to know which
       ;; transposition to start in (always 0 MAJ).
       (transpositions (push '(0 MAJ) transpositions-changes))
       ;; The set-map is assembled from the transpositions list.
       (sm 
        (loop for trnsp in transpositions
           collect (format nil "~a-~a" (first trnsp) (second trnsp))))
       ;; Each pattern type may have more than one possible combination of
       ;; rthm-seqs. These are kept in the combos-al assoc list and looked up
       ;; by random (random-rep so fixed and reset) to create, first, the
       ;; rsm-combos and then the rthm-seq-map below.
       (combos-al
        (make-assoc-list 
         'combos
         '((fauxbourdon-a-maj ((fx-1-maj-c fx-1-maj-a fx-1-maj-t 2-rest)
                               (fx-1-maj-c fx-1-maj-a 2-rest fx-2-maj-t)
                               (fx-3-maj-c fx-1-maj-c 2-rest fx-2-maj-t)))
           (fauxbourdon-a-min ((fx-1-min-c fx-1-min-a fx-1-min-t 2-rest)
                               (fx-1-min-c fx-1-min-a 2-rest fx-2-min-t)))
           (ruggiero-a-maj ((rg-1-maj-c rg-1-maj-a rg-1-maj-t 2-rest)))
           (ruggiero-a-min ((rg-1-min-c rg-1-min-a rg-1-min-t 2-rest)
                            (rg-4-min-c rg-4-min-a 2-rest rg-4-min-b)))
           (ruggiero-b-maj ((rg-2-maj-c rg-2-maj-a 5-rest rg-2-maj-t)))
           (ruggiero-b-maj-to-min ((rg-2-min-c rg-2-min-a 5-rest rg-2-min-t)))  
           (ruggiero-c-maj ((rg-3-maj-c rg-3-maj-a rg-3-maj-t rg-3-maj-b)))
           (ruggiero-d-min-to-maj ((rg-5-min-c rg-5-min-a rg-5-min-t
                                               rg-5-min-b)))
           (ruggiero-e-maj ((rg-6-maj-c rg-6-maj-a 2-rest rg-6-maj-b)))
           (sekund-a-maj ((sek-1-maj-c sek-1-maj-a sek-1-maj-t sek-1-maj-b)
                          (sek-2-maj-c sek-2-maj-a sek-2-maj-t sek-2-maj-b)))
           (sekund-a-min ((sek-3-min-c sek-3-min-a sek-3-min-t sek-3-min-b)))
           (ped-a-maj ((ped-1-maj-c ped-1-maj-a ped-1-maj-t ped-1-maj-b)))))) 
       ;; This collects the lists of combinations of rthm-seqs, one for each
       ;; instrument in each sublist. The sublists are separated out into
       ;; further sublists for each instrument then in the next step.
       (rsm-combos 
        (let* (c)
          (random-rep 1 t) ; reset random state each time for same results
          (loop for s in seq-seq
             do (setf c (get-data-data s combos-al))
             collect
               (nth (random-rep (length c)) c))))
       ;; Assembling the rthm-seq-map from rsm-combos
       (rsm 
        (loop for p in '(vo vt va vc)
           for n from 0
           collect
             (list p 
                   (flatten
                    (loop for c in rsm-combos
                       collect 
                         (list (nth n c)))))))
       ;; For each rthm-seq, it is essential to define the highest and lowest
       ;; pitch in the sequence. This is done in an assoc-list here for easy
       ;; lookup. The ID of the rthm-seq is stored with the lowest then the
       ;; highest pitch in a sublist. The pitches are all taken from C
       ;; transpositions of the seqs. One set-limit- is created for each bar to
       ;; avoid interpolation and ensure that the pitches can be fixed.
       (lims-al 
        (make-assoc-list 'set-lims
                         '((2-rest (a4 a4))
                           (5-rest (a4 a4))
                           (fx-1-maj-c (fs4 a4))
                           (fx-1-maj-a (b3 e4))
                           (fx-1-maj-t (g3 c4))
                           (fx-1-min-c (fs4 af4))
                           (fx-1-min-a (b3 ef4))
                           (fx-1-min-t (g3 c4))
                           (fx-2-maj-t (g2 c3))
                           (fx-2-min-t (g2 c3))
                           (fx-3-maj-c (b4 e5))
                           (rg-1-maj-c (b4 c5))
                           (rg-1-maj-a (c4 g4))
                           (rg-1-maj-t (c3 g3)) 
                           (rg-1-min-c (b4 c5))
                           (rg-1-min-a (c4 g4))
                           (rg-1-min-t (c3 g3)) 
                           (rg-2-maj-c (ef4 c5))
                           (rg-2-maj-a (c4 f4))
                           (rg-2-maj-t (bf2 g3))
                           (rg-2-min-c (ef4 c5))
                           (rg-2-min-a (c4 f4))
                           (rg-2-min-t (bf2 g3))
                           (rg-3-maj-c (gs4 c5))
                           (rg-3-maj-a (e4 g4))
                           (rg-3-maj-t (b3 e4))
                           (rg-3-maj-b (a2 a3))
                           (rg-4-min-c (b4 c5))
                           (rg-4-min-a (c4 g4))
                           (rg-4-min-b (g2 g3))
                           (rg-5-min-c (b4 c5))
                           (rg-5-min-a (e4 g4))
                           (rg-5-min-t (c4 d4))
                           (rg-5-min-b (g2 af3))
                           (rg-6-maj-c (c5 g5))
                           (rg-6-maj-a (b4 c5))
                           (rg-6-maj-b (c3 g3))
                           (sek-1-maj-c (e5 f5))
                           (sek-1-maj-a (c5 c5))
                           (sek-1-maj-t (f4 g4))
                           (sek-1-maj-b (a2 c3))
                           (sek-2-maj-c (e5 g5))
                           (sek-2-maj-a (c5 d5))
                           (sek-2-maj-t (g4 a4))
                           (sek-2-maj-b (b2 c3))
                           (sek-3-min-c (ef5 f5))
                           (sek-3-min-a (c5 c5))
                           (sek-3-min-t (f4 g4))
                           (sek-3-min-b (af2 c3))
                           (ped-1-maj-c (c5 c5))
                           (ped-1-maj-a (g4 a4))
                           (ped-1-maj-t (e4 f4))
                           (ped-1-maj-b (c3 c3)))))
       ;; Then the set-limits-high and -low are collected into separate lists
       ;; and stored in lims-lo-hi.
       (lims-lo-hi
        (loop for n from 0 to 1
           collect 
             (loop for p in rsm
                collect 
                  (loop for rs in (second p)
                     collect (note-to-midi
                              (nth n (get-data-data rs lims-al)))))))
       ;; This then goes through the transpositions variable to transpose each
       ;; set-limit value (MIDI pitch number) accordingly to correspond to the
       ;; current set transposition.
       (transposed-lims-lo-hi
        (loop for hl in lims-lo-hi
           collect 
             (loop for p in hl
                for pl in '(vo vt va vc)
                collect
                  (list pl
                        (loop for n in p
                           for i in transpositions
                           for x from 1
                           collect x
                           collect (+ n (first i)))))))
       ;; These are a number of variables used for rhythmic units, so that they
       ;; can be spliced together within rthm-seqs that have identical rhythms
       ;; but different pitch-seq-numbers (such as minor vs. major etc.)
       ;; I'm not sure how effective this is. I thought it would be easier, and
       ;; it is easier to some degree sometimes, but not always.
       ;; time signature
       (ts '((4 4)))
       ;; basic rest rhythm
       (r-0 '((w)))
       ;; various multi-bar rest sequences
       (2-bars-rest-ts `((,@ts ,@r-0) ,r-0))
       (5-bars-rest-ts `((,@ts ,@r-0) ,r-0 ,r-0 ,r-0 ,r-0))
       ;; first three bare (functionless) rhythm sequences
       (r-1 '(q h q))
       (r-2 '(+q q h))
       (r-3 '(h h))
       ;; BASIC FAUXBOURDON RHYTHM SEQ
       ;; assigning functions (as variable names) to bare rhythm sequences
       (5-6-sus-7-6 `(,@r-1))
       (tie-to-cantizans `(,@r-2))
       ;; creating variables for fauxbourdon voices
       (sus-7-6-to-half-cadence-cntzns-ts `((,@ts ,@5-6-sus-7-6)
                                            ,tie-to-cantizans)) 
       (four-halves-to-half-cadence-altzns-tnzns-ts `((,@ts ,@r-3) ,r-3))
       ;; fourth and fifth bare rhythms
       (r-4 '(w))
       (r-5 '(- e e - q h))
       ;; BASIC 2-BAR RUGGIERO RHYTHM SEQ
       ;; assigning functions (as variable names) to bare rhythm sequences
       (cantizans-interruptus `(,@r-1))
       (whole `(,@r-4))
       ;; creating variables for 2-bar ruggiero voices
       (2-bar-cadence-cantizans-ts `((,@ts ,@cantizans-interruptus) ,whole))
       (2-bar-cadence-tenorizans-ts `((,@ts ,@r-5) ,whole))
       (2-bar-cadence-bassizans-ts `((,@ts ,@whole) ,whole))
       ;; sixth bare rhythm
       (r-6 '(q q h))
       ;; assigning functions (as variable names) to bare rhythm sequences       
       (tenorizans-interruptus-1 `(,@r-2))
       (tenorizans-interruptus-2 `(,@r-6))
       ;; BASIC 5-BAR FALLING-5THS RUGGIERO SEQUENCE
       ;; creating variables for 5-bar falling-5ths ruggiero voices
       (5-bars-falling-fifths-cntzns-tnzs-ts 
        `((,@ts ,@cantizans-interruptus) ,tenorizans-interruptus-1
          ,cantizans-interruptus ,tenorizans-interruptus-1 ,whole))
       (5-bars-falling-fifths-tnzs-cntzns-ts 
        `((,@ts ,@tenorizans-interruptus-2) ,cantizans-interruptus
          ,tenorizans-interruptus-1 ,cantizans-interruptus ,whole))
       (5-bars-falling-fifths-bsszns-ts 
        `((,@ts ,@whole) ,whole ,whole ,whole ,whole))
       ;; seventh bare rhythm
       (r-7 '(h. q))
       ;; 3-BAR RUGGIERO IV-I-V-I MODULATION SEQUENCE
       ;; creating variables for 3-bar ruggiero IV-I-V-I modulation voices 
       (two-halves `(,@r-3))
       ;; eighth and ninth bare rhythms
       (r-8 '(q q q q))
       (r-9 '(q q q. e))
       ;; NEIGHBOR ELABORATIONS FOR RUGGIERO VOICES
       ;; creating elaborated upper-/lower-neighbor 2-bar bassizans
       (2-bar-upper-lower-neighbor-octave-bassizans-ts `((,@ts ,@r-8) ,whole))
       ;; creating elaborated lower-neighbor 2-bar altizans and tenorizans
       (2-bar-lower-neighbor-altizans-ts `((,@ts ,@r-9) ,whole))
       (2-bar-lower-neighbor-tenorizans-ts `((,@ts ,@r-6) ,whole))
       ;; BASIC 2-BAR SEKUND-AKKORD SEQUENCE
       ;; creating variable for basic sekund-akkord sequence
       (sekund-core `((,@ts ,@r-3) ,whole))
       ;; BASIC 2-BAR PEDAL-POINT SEQUENCE
       ;; creating variables for the inner and outer voices of the basic 2-bar
       ;; pedal-point sequence
       (2-bar-pedal-sustained-outer-voices-ts `((,@ts ,@whole) ,whole))
       (2-bar-pedal-moving-inner-halves-ts `((,@ts ,@r-3) ,whole))
       ;; The call to make-slippery-chicken.
       (tonal-example
        (make-slippery-chicken
         '+tonal-example+
         :title "tonal example"
         :tempo-map '((1 (q 112)))
         :ensemble '(((vo (violin :midi-channel 1))
                      (vt (violin :midi-channel 2))
                      (va (viola :midi-channel 3))
                      (vc (cello :midi-channel 4))))
         :set-palette sp
         :set-map `((1 ,sm))
         :set-limits-low (first transposed-lims-lo-hi)
         :set-limits-high (second transposed-lims-lo-hi)
         :avoid-melodic-octaves nil
         :avoid-used-notes nil
         :rthm-seq-palette 
         ;; The rthm-seqs: "-c" means cantus, "-a" means alto, "-t" means
         ;; tenor, "-b" means bass.
         `((2-rest (,2-bars-rest-ts))
           (5-rest (,5-bars-rest-ts))
           ;; FAUXBOURDON SEQUENCES
           ;; fauxbourdon 1 major
           (fx-1-maj-c (,sus-7-6-to-half-cadence-cntzns-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(g4 a4 g4 fs4 g4) core-set-maj))))
           (fx-1-maj-a (,four-halves-to-half-cadence-altzns-tnzns-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(e4 d4 c4 b3) core-set-maj))))
           (fx-1-maj-t (,four-halves-to-half-cadence-altzns-tnzns-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(c4 b3 a3 g3) core-set-maj))))
           ;; fauxbourdon 1 minor
           (fx-1-min-c (,sus-7-6-to-half-cadence-cntzns-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(g4 af4 g4 fs4 g4) core-set-min))))
           (fx-1-min-a (,four-halves-to-half-cadence-altzns-tnzns-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(ef4 d4 c4 b3) core-set-min))))
           (fx-1-min-t (,four-halves-to-half-cadence-altzns-tnzns-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(c4 bf3 af3 g3) core-set-min))))
           ;; fauxbourdon 2 major
           (fx-2-maj-t (,four-halves-to-half-cadence-altzns-tnzns-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(c3 b2 a2 g2) core-set-maj))))
           ;; fauxbourdon 2 minor
           (fx-2-min-t (,four-halves-to-half-cadence-altzns-tnzns-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(c3 bf2 af2 g2) core-set-min))))
           ;; fauxbourdon 3 major
           (fx-3-maj-c (,four-halves-to-half-cadence-altzns-tnzns-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(e5 d5 c5 b4) core-set-maj))))
           ;; RUGGIERO SEQUENCES
           ;; ruggiero 1 major
           (rg-1-maj-c (,2-bar-cadence-cantizans-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(b4 c5 b4 c5) core-set-maj))))
           (rg-1-maj-a (,2-bar-cadence-tenorizans-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(g4 f4 e4 d4 c4) core-set-maj))))
           (rg-1-maj-t (,2-bar-cadence-bassizans-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(g3 c3) core-set-maj))))
           ;; ruggiero 1 minor
           (rg-1-min-c (,2-bar-cadence-cantizans-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(b4 c5 b4 c5) core-set-min))))
           (rg-1-min-a (,2-bar-cadence-tenorizans-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(g4 f4 ef4 d4 c4) core-set-min))))
           (rg-1-min-t (,2-bar-cadence-bassizans-ts
                        :pitch-seq-palette 
                        (,(pitches-to-pseq '(g3 c3) core-set-min))))
           ;; ruggiero 2 major
           (rg-2-maj-c (,5-bars-falling-fifths-cntzns-tnzs-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(b4 c5 bf4 a4 g4 a4 bf4 af4 g4 f4
                                             ef4) core-set-maj))))
           (rg-2-maj-a (,5-bars-falling-fifths-tnzs-cntzns-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(f4 e4 d4 e4 f4 ef4 d4 c4 d4 ef4 d4
                                             ef4) core-set-maj))))
           (rg-2-maj-t (,5-bars-falling-fifths-bsszns-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(g3 c3 f3 bf2 ef3) core-set-maj))))
           ;; ruggiero 2 minor
           (rg-2-min-c (,5-bars-falling-fifths-cntzns-tnzs-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(b4 c5 bf4 a4 g4 a4 bf4 af4 gf4 f4
                                             ef4) core-set-maj)))) 
           (rg-2-min-a (,5-bars-falling-fifths-tnzs-cntzns-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(f4 e4 d4 e4 f4 ef4 d4 c4 d4 ef4
                                             d4 ef4) core-set-maj))))
           (rg-2-min-t (,5-bars-falling-fifths-bsszns-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(g3 c3 f3 bf2 ef3) core-set-maj))))
           ;; ruggiero 3 major
           (rg-3-maj-c (((,@ts ,@cantizans-interruptus) ,whole
                         ,tie-to-cantizans) 
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(b4 c5 bf4 a4 gs4 a4)
                                           core-set-maj))))
           (rg-3-maj-a (((,@ts ,@r-6) ,tenorizans-interruptus-1 ,two-halves)
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(g4 g4 g4 f4 e4 e4 e4)
                                           core-set-maj))))
           (rg-3-maj-t (((,@ts ,@r-6) ,r-7 ,two-halves)
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(d4 e4 d4 d4 c4 b3 cs4)
                                           core-set-maj))))
           (rg-3-maj-b (((,@ts ,@whole) ,two-halves ,two-halves)
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(g3 d3 a3 e3 a2) core-set-maj))))
           ;; ruggiero 4 minor
           (rg-4-min-c (,2-bar-cadence-cantizans-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(b4 c5 b4 c5) core-set-min))))
           (rg-4-min-a (,2-bar-cadence-tenorizans-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(g4 f4 ef4 d4 c4) core-set-min))))
           (rg-4-min-b (,2-bar-upper-lower-neighbor-octave-bassizans-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(g3 fs3 g3 g2 c3) core-set-min))))
           ;; ruggiero 5 minor
           (rg-5-min-c (,2-bar-cadence-cantizans-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(b4 c5 b4 c5) core-set-min))))
           (rg-5-min-a (,2-bar-lower-neighbor-altizans-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(g4 fs4 g4 f4 e4) core-set-min))))
           (rg-5-min-t (,2-bar-lower-neighbor-tenorizans-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(d4 c4 d4 c4) core-set-min))))
           (rg-5-min-b (,2-bar-upper-lower-neighbor-octave-bassizans-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(g3 af3 g3 g2 c3) core-set-min))))
           ;; ruggiero 6 major
           (rg-6-maj-c (,2-bar-cadence-tenorizans-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(g5 f5 e5 d5 c5) core-set-maj))))
           (rg-6-maj-a (,2-bar-cadence-cantizans-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(b4 c5 b4 c5) core-set-maj))))
           (rg-6-maj-b (,2-bar-cadence-bassizans-ts
                        :pitch-seq-palette
                        (,(pitches-to-pseq '(g3 c3) core-set-maj))))
           ;; SEKUND SEQUENCES
           ;; sekund 1 major
           (sek-1-maj-c (,sekund-core
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(e5 e5 f5) core-set-maj))))
           (sek-1-maj-a (,sekund-core
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(c5 c5 c5) core-set-maj))))
           (sek-1-maj-t (,sekund-core
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(g4 g4 f4) core-set-maj))))
           (sek-1-maj-b (,sekund-core
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(c3 bf2 a2) core-set-maj))))
           ;; sekund 1 major
           (sek-2-maj-c (,sekund-core
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(e5 fs5 g5) core-set-maj))))
           (sek-2-maj-a (,sekund-core
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(c4 d5 d5) core-set-maj))))
           (sek-2-maj-t (,sekund-core
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(g4 a4 g4) core-set-maj))))
           (sek-2-maj-b (,sekund-core
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(c3 c3 b2) core-set-maj))))
           ;; sekund 3 minor
           (sek-3-min-c (,sekund-core
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(ef5 e5 f5) core-set-min))))
           (sek-3-min-a (,sekund-core
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(c5 c5 c5) core-set-min))))
           (sek-3-min-t (,sekund-core
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(g4 g4 f4) core-set-min))))
           (sek-3-min-b (,sekund-core
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(c3 bf2 af2) core-set-min))))
           ;; PEDAL SEQUENCES
           ;; pedal 1 major
           (ped-1-maj-c (,2-bar-pedal-sustained-outer-voices-ts
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(c5 c5) core-set-maj))))
           (ped-1-maj-a (,2-bar-pedal-moving-inner-halves-ts
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(g4 a4 g4) core-set-maj))))
           (ped-1-maj-t (,2-bar-pedal-moving-inner-halves-ts
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(e4 f4 e4) core-set-maj))))
           (ped-1-maj-b (,2-bar-pedal-sustained-outer-voices-ts
                         :pitch-seq-palette
                         (,(pitches-to-pseq '(c3 c3) core-set-maj)))))
         :rthm-seq-map `((1 ,rsm)))))
  ;; Enharmonics have to be adjusted first. The "enharmonics" method allows the
  ;; user to give a range of measures that are to be affected and specify which
  ;; current pitches are to be flipped enharmonically.
  (loop for d in '((14 16 vo (cs5)) (15 16 vt (fs4)) (19 27 vt (af4))
                   (25 25 va (af4)) (27 28 vo (cs5)) (27 30 vt (fs4 cs5)) 
                   (27 30 va (fs4)) (42 45 vo (cs5)) (43 44 vt (fs4))
                   (47 59 vo (bf5 af5)) (47 59 vt (ef5 af5)) 
                   (47 59 va (bf4 ef5)) (61 65 vo (ef5)) (61 66 vt (bf4 af4))
                   (70 70 vo (af5)))
     do 
       (enharmonics tonal-example (first d) (second d) (third d) 
                    :pitches (fourth d)))
  ;; The "enharmonics" method doesn't allow for "white-key" notes to be
  ;; enharmonically flipped, so some of the pitches have to be changed using
  ;; "enharmonic" instead, which has a "force-naturals" option.  
  ;;
  ;; MDE Fri May 17 22:28:54 2013 -- because we use random-rep for the
  ;; rthm-seq-map (voicings) above we can only change these specific
  ;; enharmonics when working with SBCL so in other lisps the spellings will be
  ;; nasty here.
  #+sbcl
  (loop for en in '((17 1 vt) (17 3 vo) (17 3 vt) (20 2 vo) (20 2 vt) (21 1 vo)
                    (21 3 vo) (21 2 vc) (24 2 vo) (24 2 vt) (25 1 vo) (25 3 vo)
                    (25 2 vt) (26 1 vt) (27 2 vt) (28 2 va) (29 2 vo) (29 3 vo)
                    (29 1 vc) (30 2 vt) (45 2 vo) (45 3 vo) (45 1 vt) (45 3 vt)
                    (47 2 vo) (48 1 vc) (49 1 vt) (49 3 vt) (52 1 vc) (53 1 vt)
                    (53 3 vt) (57 2 vo) (58 1 vc) (59 1 vt) (59 3 vt) (62 2 vo)
                    (63 1 vo) (62 2 vt) (61 2 va) (62 1 va))
     do (enharmonic (get-event tonal-example (first en) (second en) (third en))
                    :force-naturals t))
  (loop for b-k in '((12 (ef major)) (19 (fs minor)) (27 (gf major))
                     (32 (ef major)) (47 (fs major)) (68 (a minor)))
     do
       (loop for p in '(vo vt va vc)
          do
            (change-bar-line-type tonal-example (1- (first b-k)) 1)
            (add-mark-before 
             (get-event tonal-example (first b-k) 1 p)
             `(key ,@(second b-k)))))
  ;; specify the staff names of the two violins
  (loop for n in '((vo "violin 1" "vln 1") (vt "violin 2" "vln 2"))
     do 
       (setf (staff-name 
              (get-data-data (first n) (ensemble tonal-example))) 
             (second n))
       (setf (staff-short-name 
              (get-data-data (first n) (ensemble tonal-example)))
             (third n)))
  (midi-play tonal-example :midi-file "/tmp/tonal.mid")
  (cmn-display tonal-example :file "/tmp/tonal.eps" 
               :auto-bar-nums 5
               :respell-notes nil
               :auto-clefs nil)
  (write-lp-data-for-all tonal-example
                         :respell-notes nil
                         :auto-clefs nil))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; EOF
