;                                 The Lisp Kernel
;                                   August 1999
;                              
; This version was compiled successfully on an Intel machine running
; Red Hat Linux and on a  Silicon Graphics station, running
; two different versions of Common Lisp.

;        copyright c 1988, 1992, 1994, 1995, 1999 by John Rahn


;	The main source code is in kernel.cl.
; 	It should load and run in any 
;	Common Lisp. When possible it should be compiled and the resulting
;	.fasl file loaded. The compiler may or may not give a number of warning
;	messages during compilation. 
;	These can be ignored in most implementations.
;
; 
; 	Kernel.cl contains several subfiles, identifiable by their headers.
; 	SETUP.CL sets you up to use a csound
;	orchestra (given in file class.orc). 
;	The Lisp PLAY function may need some
;	editing depending on your local file setup. 
;	Section FM.CL contains a few
;	sample fm sounds using functions in SETUP.CL 
;	and the FM instrument in file class.orc.
;
;
;      WHAT IS IT? 
;
;            The Lisp Kernel is intended to sit in the logical middle of a
;       music workstation. It comprises primarily a data-structure,
;       database facilities, and a composing language called Lispfront.
;       The data-structure should be general enough so that any
;       event-oriented musical data can be translated to and from the
;       Kernel.  There are also utilities for music theory and for composing.
;       The idea is that a composer can compose in the Kernel and
;       output on whatever device is handy, such as
;       csound, cmix, Music4P, and MIDI.  

;            For fuller information, see:
        
;        John Rahn. "Computer Music: A View from from Seattle."
;        Computer Music Journal 12/3 (Fall 1988): 15-30.
;        This will give some background but is now somewhat out of date.

;        John Rahn. "The Lisp Kernel: A Portable Environment for Musical 
;        Composition." Forthcoming in the Proceedings of the 
;        First International Workshop on Music and AI 
;        (September 15-16, 1988, Sankt Augustin, Germany).  
;        This talk is available in blake's ~/public/rahn/kernel.doc, 
;	 an ASCII file. It gives a good overview of the ideas 
;	 behind the LISP Kernel and details
;        about its structures and implementation.

;        John Rahn. "The LISP Kernel: 
;	 A Portable Software Environment for Composition."
;        Computer Music Journal 14/4. 
;        This is a much revised, rewritten, and in some ways expanded version
;        of the Sankt Augustin talk.

;        John Rahn, Richard Karpen, Craig Weston, and Charles Hiestand.
;        "Using the LISP Kernel Musical Environment." Musicus 1/2 (1990)
;        This article is available dor anonymous FTP as Musicus.ascii,
;        and Musicus.wn (NeXT WriteNow format).
;        It shows how some of us are using the LISP Kernel as of December 1989,
;        with plentiful LISP source code examples. 
;	 Applications described include
;        compositional tools, granular synthesis, and serial-theory-to-sound.


;        Other articles of interest include:

;        John Rahn. "Processing Musical Abstraction: Remarks on LISP,
;        the NeXT, and the Future of Musical Computing." Perspectives of
;        New Music 28/1 (Winter 1990)

;        Peter Desain. "LISP as a Second Language: Functional Aspects."
;        Perspectives of New Music 28/1 (Winter 1990)



;       WHAT DOES THIS VERSION CONTAIN? 

;            It contains the basic data-structure, database,
;       Lispfront, MIDI I/O via Adagio, and output facilities for Music4P,
;       CSound, and the NeXT Music Kit. 

;       Most users in 1999 will want to run it into Csound.

;       It also contains a sample setup in file setup.cl which is designed
;       to work with the csound orchestra in file class.orc, and examples
;       in file fm.cl using the fm instrument in class.orc,
;       and a number of useful functions such as SOUND-STREAM.
;	There is a package of utilities for microtonal work.
;	There is a graphical interface via EnvelopeEd,
;	and provision for interated-function-system graphics/music.
;       In general, the more compositionally oriented functions
;       and examples are located toward the end of the file kernel.cl,
;       and basic underlying machinery is toward its beginning.

;       WHAT WILL IT RUN ON AND UNDER? 

;       Kernel.cl is a version that will run on any full implementation of
;       Common Lisp. It has been run in Kyoto Common Lisp and in
;       Allegro Common Lisp from Franz, Inc. on the NeXT machine.
;       The 1999 version runs on Intel and Silicon Graphics stations
;       in more recent versions of Common Lisp.


;       There is also a GH version that was developed to run on an 
;	IBM AT under Gold Hill Common Lisp (subset) version 2.2. 
;       The MIDI I/O in all cases is rudimentary, via Adagio and the
;       Carnegie Mellon C MIDI Toolkit, which is in the public domain.
;       MIDI output is also available via the NeXT Music Kit.

;         This program was conceived in the mid 1980s, written on an
;         Atari computer running Xlisp, and ported painlessly
;         to various versions of Common Lisp, starting with the
;         Next Machine's Franz Lisp in the late 1980s.


;       HOW DO I USE IT? 

;            First skip to the file named or section headed  
;       "setup.cl"  or even "fm.cl"
;       and read over that. It should then be possible for you to use the
;       procedures defined there to compose your own pieces.  
;       Typing (BELLS) into Lisp should create some complex
;       FM notes, which you can see on the screen using (SEE),
;       or using (SHOW) to see the complete parameters.
;       If your filesystem and csound is properly set up,
;       typing (PLAY) in Lisp should run a job so that you hear the notes
;       at the end through the NeXT sound system.
;       You may have to edit the Lisp (PLAY) function
;       to fit your local file setup. See below for directions on 
; 	how to set up to run csound on a NeXT using the existing (PLAY). 

;       ; ------- * OUTPUT UTILITIES TO SYNTHESIS SOFTWARE * ------.  
;       If you are doing the stages in (PLAY) separately:
;       To write out a piece as an input file for Music4P, use the procedure
;       PRINT4P. Output to CSound is via PRINTCS. For Music Kit, PRINTMK --
;       see definitions and comments in  the section labelled:
;          " ------- * OUTPUT UTILITIES TO SYNTHESIS SOFTWARE * ------".
;       To hear the piece over MIDI, use the procedure MIDI-OUT, whose
;       source code is found in the MIDI.LSP section.  This also contains
;       a MIDI-IN procedure. We have not been using MIDI much here, so
;       these procedures may not be reliable. 
;	These functions were designed for use
;       on an IBM AT under Gold Hill CL. 


;       WHAT ABOUT PROBLEMS? 

;            This version is totally without warranty, express or
;       implied.  Use at your own risk.  If you come up
;       with a fix or added feature, please do send it along. I can be
;       reached at the network address: 
;       jrahn@u.washington.edu 


;       My mailing address is: 
;            John Rahn 
;            Music Box 353450
;            University of Washington 
;            Seattle, WA 98195-3450
;            USA 




;       Have fun! 

; -----------------------------------------------------------------
;       	  Setting up your NeXT to run under (PLAY)
;
;	0. Copy files kernel.cl and class.orc to your directory.
;	1. type cl into a Unix window.  
;		If cl is not running, get your system
;		administrator to install Common Lisp.
;		(The kernel assumes case insensitive-upper,
;		which is the Common Lisp standard, but will
;		also run under case sensitive-lower.)
;	2. edit or create a file in your home directory called
;	  	.clinit.cl   so that it contains the line
;		(LOAD "KERNEL.FASL")
;	3. edit your home directory's .cshrc file to add the line
;		setenv SFDIR ~/snd
;		where ~/snd is the name of the directory you want
;		the soundfiles created by csound to appear in.
;		This should be on a disk or partition with plenty of space.
;	4. edit the source file kernel.cl so the the PLAY function
;		refers to the SFDIR you defined in its (SHELL "PLAY ...)
;		The existing PLAY assumes SFDIR is a subdirectory (called snd)
;		of the directory you use for cl.
;	5. type csound into the Unix shell. If nothing happens,
;		get your system person to install csound (ftp from MIT).
;	6. type sndplay into a Unix window to check that some Unix-shell
;		executable named "sndplay" plays soundfiles. You can
;		substitute or alias in your .cshrc --  for example:
;		alias sndplay play. NeXTs come with a sndplay utility.
;	7. type cl, and type into the into cl window
;			(COMPILE-FILE KERNEL.CL)
;		This creates a compiled kernel.fasl file.
;	8. type (exit) to exit cl, then type cl again.
;		File kernel.fasl will now be loaded automatically every time
;		you start a cl process (due to .clinit.cl).
;	9. Enjoy. You should be ready to run.



; -------------------------------------------------------------------------
; file kernel.cl      Lisp Kernel      John Rahn 
; full Common Lisp version  

; N.B to run Gold Hill CL 2.2 (about 60% of the CL standard)
; simply comment out the second defun of FORMATF
; and load GHMIDI.LSP after KERNEL.LSP


;  a music program front end, called the Lisp Kernel

   
; The Lisp Kernel assumes a data structure (prop value prop2 val2 ...)
; where props are atoms and vals are lists.
; This note-structure is a set of property-value pairs implemented as a list
; of property-value pairs. Each such set is to be interpreted as a "note".
; Note-structures can each be attached to a symbol as its "property list"
; or slung around in other ways just as lists,
; e.g. can be assembled into sets or lists of notes.
 
; The Kernel expects certain names for five properties, which should
; be present for any note, so every note-structure will be a superset
; of:
; (INSNO (instrument-number) START (start-time) DUR (duration)
;    AMP (amplitude) PITCH (pitch))
; The values have these meanings: insno = instrument number e.g. 1 ,
; insname is name of type of instrument e.g. 'FM or 'CELLO,
; start-time in beats (default MM 60), duration in beats, 
; amplitude is relative amplitude,
; pitch in octave.pc notation unless otherwise specified.
; All other note properties are up to the user. There is no limit on the
; number of properties (though Music4P can handle only 480 per note),
; and the names of the other properties can be anything the user wishes.
; The order in which the property-value pairs are listed is immaterial.
; Apologies for the regimentation of these standard five, but they
; are expected by the MIDI and Music4P interfaces to the Kernel.

; -----------------------------------------------------------------


;(defpackage "kernel")
;(provide "kernel")
;(in-package "kernel")
;(use-package "kernel")




; system thing
(setq *global-gc-behavior* :auto)


; handy loaders and compilers

(defun lme () (load "kernel.opera.cl" :print t))

(defun cme () (compile-file "kernel.opera.cl"))

(defun clme () (compile-file "kernel.opera.cl")
               (load "kernel.opera.fasl" :print t))

(defun lx () (load "x.cl" :print t))

(defun cx () (compile-file "x.cl"))

(defun clx () (compile-file "x.cl")
               (load "x.fasl" :print t))


;  ------------------- *BASIC FUNCTIONS* ------------------
 
; HASP returns the tail of the list, starting with PROP,
; IFF some property is PROP, else nil.
(defun hasp (note prop)             ; like member, returns list from prop 
   (and note                        ; but looks only at odd-numbered elements
           (cond ((eq prop (car note))  note )
                 (t  (hasp (cddr note) prop))
            )
    )
 )
 
; GETV is the basic accessor
(defun getv (note prop)            ; gets value of prop in note-structure
       (cadr (hasp note prop) ) )

; The corresponding constructors and updaters are the PUTPV family --
; see below under * NOTE-STRUCTURE OPERATORS *


; HASPROP and GETVAL assume the set of property-value pairs
; is attached to a symbol as its property list.
(defun hasprop (sym prop)         ; gives plist of symbol to hasp
       (hasp (getpl sym) prop)
 )

(defun getval (sym prop)          ; gets value of prop from plist
   (getv (getpl sym) prop))       ; e.g. (getval 'a1 'pitch)


; Some dialects of Lisp may have a more efficient way to get the
; value of a property from the property-list of an atom; e.g. in 
; CL simply (GET SYM PROP). 
; GETVAL is our local version to allow adaptation to other lexically
; scoped dialects such as Scheme.
  
; GETPL gets complete symbol property list; isolates from dialect.
; equals CL (SYMBOL-PLIST sym)
(defun getpl (sym) (symbol-plist sym)) ; e.g (getpl 'a1)
(defun putpl (sym pl) (setf (symbol-plist sym) pl)) ; e.g. (putpl 'a1 '(a b))


; ------------- *MACROS FOR HANDY HACKING* --------------------------
; should probably eliminate these lest they lead to cancer of the semicolon

; GV macro puts value -- equivalent to GETVAL
(defmacro gv (sym prop)   ; macro version needs no quoting, e.g. (gv a1 pitch)
       `(cadr (hasprop ',sym ',prop))
 )

; PPV goes with macro GV -- use is  e.g. (ppv pitch format-property)
; equivalent to PUTPVAL
(defmacro ppv (sym prop value)
   `(putpval ',sym ',prop ',value))

; GPL and PPL macros equivalent to GETPL and PUTPL
(defmacro gpl (sym) `(symbol-plist ',sym))  ; takes unquoted symbol as arg
                                               ; e.g. (gpl a1)   
(defmacro ppl (sym pl) `(setf (symbol-plist ',sym) ,pl))  ; e.g. (ppl a1 '(a b))

; ---------------------------------------------------------

; ADDTOSET is a utility that maintains formal sets, implemented as lists
(defun addtoset (element subset)  ; adds element to end of set list 
       (cond  ((member element subset) subset)   ; no duplicated elements
              (t (append subset (list element))  ) 
        )
 )
 
;---------------* NOTE-STRUCTURE OPERATORS *----------------------
; The PUTPVal family of utilities is basic. They add a value to the value list
; of an existing property for a given note, or if the property is not on
; the note-structure, add both the new property and its new value.

; Thus they are both constructors and updaters. 
; (GETV and GETVAL are the corresponding accessors.)

; N.B. They maintain formal sets of <prop val> ordered pairs.

; PUTs append the new value to the value list of prop.
; ASSIGNs replace the contents of the value list of prop with the new value.

; PUTPV and := expect a variable whose value is the note-structure.
; PUTPVAL and ASSIGN expect a symbol with the note-structure as its plist.
; All functions return the new, altered note-structure in its entirety.

; Function := assigns new value to prop for note, returns new note-structure
; with no side-effects.
(defun := (note prop value)
   (labels ((assign-aux (note prop value result)
              (cond ((null note) (reverse result))
                (t (let ((noteprop (car note))
                             (noteval (cadr note)))
                    (cond ((eq noteprop prop)
                           (setq noteval (list value))   ))
                    (assign-aux (cddr note) 
                              prop 
                              value 
                              (cons noteval (cons noteprop result))
                     )
                
                    )
                 )
               )
            ))
    
   (cond ((not (hasp note prop))
          (append note
                  (cons prop (list (list value))))
          )
         (t (assign-aux note prop value nil))
    )
) )


; Function putpv appends new value to end of value list for prop for note
; and returns new note-structure (no side-effects).
(defun putpv (note prop value)
   (labels (( putpv-aux (note prop value result)
      (cond ((null note) (reverse result))
            (t (let ((noteprop (car note))
                     (noteval (cadr note)))
                    (cond ((equal noteprop prop)
                           (setq noteval (append noteval (list value))) ))
                    (putpv-aux (cddr note) 
                               prop 
                               value 
                               (cons noteval (cons noteprop result))
                     ))))))
   (cond ((not (hasp note prop))
          (append note
                  (cons prop (list (list value))))
           )
          (t (putpv-aux note prop value nil)))))


; Non-destructive PUTPVAL and ASSIGN operate on the property list of a symbol.
; They do alter plist of symbol destructively as a side-effect but that's all
; -- no side effects to values of variables.
; They return the new plist.
(defun assign (sym prop value)
   (putpl sym (:= (getpl sym) prop value)))

(defun putpval (sym prop value)
   (putpl sym (putpv (getpl sym) prop value)))

; MASS does a multiple assign using :=
; pairlist = property-value couples
(defun mass (note &rest pairlist)
   (do* ((pairs pairlist (cddr pairs))
	     (parameter (car pairs) (car pairs))
	     (value (cadr pairs) (cadr pairs))
	     )
        ((or (not parameter) (not (symbolp parameter)))
          note
         )
      (setq note (:= note parameter value))
    )
 )
; eg (mass nil 'a 1 'b 2 'c 3) returns a note-structure
;     (a (1) b (2) c (3))
;  you may end with a symbol, in which case its value is assigned nil
;   (mass 'a)   =>   (a (nil))
;  every odd position in the pairlist should be a symbol -- if not it will
;  return a note-structure containing only those pairs before the goof
;    (mass 'a 1 2)  =>  (a (1))



; ------------------------------------------
; inessential macro REFPUT 
; stores a global variable VARIABLE and its value VALUE
; globally, roughly "by reference", as a <prop value> pair on a plist.
; It returns the new value for variable via its dual, REFGET.
; macro REFGET retrieves value of global reference variable
;  Use like SETQ : (refput starter 43)   ... (refget starter)  ; no quotes 
(defmacro refget (variable)
   `(car (gv variables_by_global_reference ,variable)))
 
(defmacro refput (variable value)
   `(let (   )
      (assign 'variables_by_global_reference ',variable ,value)
      (refget ,variable)
    )
 )
 
 
;----------- * MORE NOTE-STRUCTURE OPERATORS * ------------------------
; These are rough versions; however, they do work.
; They are CL/Xlisp dependent as they use SETF -- see REMOVE-SUPERNODE
; in OOP.LSP section of the Lisp Kernel for a way to implement these
; that avoids SETF, using KEEP-IF-NOT filter (for Scheme, T, etc.)

; REMOVEVAL removes a specified value from value list for prop (for plist of sym),
; replaces new value list for prop into plist of sym,
; and returns new property list.
; (N.B. if value is nonexistent, DELETE returns the list unchanged;
; if prop is nonexistent, an error message is generated.)

(defun removeval (sym prop value) 
      (cond ( (hasprop sym prop)
                 (let ( (temporary (get sym prop) ) ) 
                        (setf (get sym prop)
                              (delete value temporary)) 
                        (getpl sym) 
                  )
             )
             (t "error - nonexistent property, a typo, or item not yet created")
       )
 )
 
  
; CL (REMPROP sym prop)  removes  both PROP and prop's VALUE from
; symbol-plist of sym. Xlisp contains REMPROP.
; e.g. (remprop 'a1 'pit)
 
; ERASEVALS sets the value list for PROP to NIL (leaves PROP in place)
(defun erasevals (sym prop)
       (cond ((hasprop sym prop)
              (setf (get sym prop) nil))
             (t "error - note or property not yet created")
        )
 )
 
(defun replaceval (sym prop oldval newval)  ; selective replace
      (removeval sym prop oldval)
      (putpval sym prop newval))
 
(defun replacevals (sym prop newval)   ; destroys entire old value list
   (assign sym prop newval))      ; same as ASSIGN
 
; -------  the equivalent operations for note-structures
;          not attached to symbols
; (kludges again)
 
(defun removepv (note-structure prop value)
   (putpl 'zzzzzzx note-structure)
   (removeval 'zzzzzzx prop value))

(defun removeprop (note-structure prop)
   (putpl 'zzzzzzx note-structure)
   (remprop 'zzzzzzx prop))
 
(defun erase (note-structure prop)
   (putpl 'zzzzzzx note-structure)
   (erasevals 'zzzzzzx prop))
 
(defun replacepv (note-structure prop oldval newval)
   (putpl 'zzzzzzx note-structure)
   (replaceval 'zzzzzzx prop oldval newval))
 
(defun replace-all (note-structure prop newval)   
   (putpl 'zzzzzzx note-structure)
   (replacevals 'zzzzzzx prop newval))
; same as := 

; -------------------* GENERAL FILTERS *----------------------------------

; -----------------  * BASIC FILTER FUNCTIONS * ------------------------
 ; simple utilities take predicate pred and list L
; to make new list missing or retaining certain elements that satisfy pred
; N.B. to convert to Xlisp or Scheme must remove each mention of FUNCALL

; keep-if equals remove-if-not
(defun keep-if (pred L)
        (do ((result nil)
             (item (car L) (car L)) 
             (L (cdr L) (cdr L)))
            ((null item) result)
            (setq result (cond ((funcall pred item) 
                                (append result (list item)))
                               (t result))       
             ) 
         )
 )
 


; Cl contains its own function for remove-if-not
;(defun remove-if-not (pred L)
;   (keep-if pred L))
 
; keep-if-not equals remove-if
(defun keep-if-not (pred L)
        (do ((result nil)
             (item (car L) (car L)) 
             (L (cdr L) (cdr L)))
            ((null item) result)
            (setq result (cond ((not (funcall pred item)) 
                                (append result (list item)))
                               (t result))       
             )  
         )
 )
 
;(defun remove-if (pred L)
;   (keep-if-not pred L))
 
; examples
;(defun predic (x) (= x 2))
;(setq ll OD'(1 2 3 4 5 2))
;(keep-if 'predic ll)
 
(defun match (x note prop)
  (equal x (car (getv note prop)))
 )
 
(defun predicate (note) (match '8.00 note 'pitch))
(defun gatherpits (obj)
   (keep-if 'predicate obj)) 
 
 
; ------------- *FILTERS FROM DATABASE OF NOTES* ----------------
 
; These filter utilities take a N-place predicate PRED and list L,
; where L is a list of note-structures,
; to return new list of note-structures
; missing or retaining certain elements that satisfy PRED
; (see MATCH below as 3-place PRED),
; for example, (keep-note-if notes match 'pitch 'csharp).

; N.B. to convert to Xlisp or Scheme must remove each mention of FUNCALL
 
; keep-note-if equals remove-note-if-not
(defun keep-note-if (L pred &rest args)
        (do* ((result nil)
             (item (car L) (car L)) 
             (L (cdr L) (cdr L)))
            ((null item) result)
            (setq result (cond ((funcall pred item args)
                                (append result (list item)))
                               (t result))       
         )   )
 )    
 
 
; keep-note-if-not equals remove-note-if
(defun keep-note-if-not (L pred &rest args)
        (do* ((result nil)
             (item (car L) (car L)) 
             (L (cdr L) (cdr L)))
            ((null item) result)
            (setq result (cond ((not (funcall pred item args)) 
                                (append result (list item)))
                               (t result))       
         )   )
 )    
 
 
; sample predicate expecting a note-structure and a List of arguments
; here (MATCH NOTE (PROP VALue))
; which if passed to keep-note-if will
; generate a list of all notes whose value for PROP matches VAL
(defun match2 (note args)
  (equal (cadr args) (car (getv note (car args))))
 )
 
; the strategy of passing ARGS as an &REST list allows KEEP-NOTE-IF
; and the related filter functions to accept N-place predicates
; whose first argument is always the note from the list of note-structures and
; whose second argument is a list of arguments.
; For example, define a predicate whose test is :
; if pitch is higher than 8.00 and (OR (instrument is 3) (color is red))
; -- a 4-place predicate (PRED NOTE ARGS) where ARGS is a list
; 3 items, pitch-break = 8.00, insno = 3, and color = red --
; effectively, (PRED NOTE PITCH-BREAK INSNO COLOR).
; KEEP-NOTE-IF as defined can now handle this or any other predicates.
; KEEP-NOTE-IF will look normal, e.g. (KEEP-NOTE-IF NOTES 'MATCH 'PITCH 7.03)
 
; ------------ * VIEWERS * -----------------------------------
; VIEW function family are utilities that
; take an item like a "note" and
; select out for display certain "fields" with their values
; in an order specified by the order of the props list parameter.

; VIEW views single note-structure
; desired properties are listed individually as &rest props
; e.g. (view x 'pitch 'fm-index)

(defun view (note-structure &rest props)
       (do* ((result nil) 
             (prop (car props) (car props))
             (props (cdr props) (cdr props)))      
            ((null prop) result)                  ; termination
            (setq result (append result (list prop (getv note-structure prop))))
 )      )
 
; VIEW-TEMPLATE
; is like view, but takes a list of properties as a second parameter
; e.g. (view-template x '(pitch stereo vowel-cf1))

(defun view-template (note-structure template)
       (do* ((result nil) 
             (prop (car template) (car template))
             (template (cdr template) (cdr template)))      
            ((null prop) result)                  ; termination
            (setq result (append result (list prop (getv note-structure prop))))
        ) 
)       
 

; VIEW-PL views plist of sym
(defun viewpl (sym &rest props)
   (view-template (getpl sym) props))
 
; STRIP-OFF-PARAMS
; takes a note-structure, returns list of values, missing each parameter
(defun strip-off-params (note-structure)
   (let ((result '() ))
      (mapcar '(lambda (x)
                  (cond ((not (or (atom x) (eq x nil))  )
                          (setq result (append result x))
                         )
                   )
                 )
                note-structure
       )
       result
    )
 )

 
; function VIEW-VALUES
; takes a note-structure and a template list of properties
; returns a list of note-structure's
; values of those properties in the specified order
; (does not return names of properties).
; thus it returns a list suitable for Music4 data or HMSL shape.
; template is analogous to what HMSL calls an instrument.
 
(defun view-values (note-structure template)
       (do* ((result nil) 
             (prop (car template) (car template))
             (template (cdr template) (cdr template)))      
            ((null prop) result)                  ; termination
            (setq result (append result (list (getv note-structure prop))))
        )
 )       
 
;;can use to make other functions, e.g.
(defun listpitches ()
      (mapcar '(lambda (x) (caar (view-values x '(pitch)))) (get-piece 'mc))
 )
 ;; returns a flat list of all the pitches of the notes in piece mc



; -------------------- * DATABASE STRUCTURE * ----------------------------

; All musical data is kept under the UNIVERSE atom
; and can be seen on the screen in its entirety by GOD:
(defun GOD () (pprint (getpl 'universe)))

; GOD is useful mainly for debugging. There are separate accessors and
; updaters for each component of the UNIVERSE data-structure, defined below.
; For each property in the data-structure there will be a
; GET, ASSIGN, and PUT.

; The structure is a hierarchical note-structure of note-structures:
;
; UNIVERSE
;   (PIECES (val) PIECE-PROPS (val) GLOBAL-PROPERTIES (val) INSTRUMENTS (val))
;
; where the values for each main property of UNIVERSE have 
; the following structures:
;
; PIECES has names of pieces for properties whose values are lists of notes:
; PIECES
;   (ALLNOTES ((note1) (note2) ...)) 
;    PIECE-NAME1 ((note1) (note2) ...)
;    .
;    .
;    .
;    )
;
; PIECE-PROPS also has names of pieces as properties, but their values are
; note-structures giving <property value> pairs that are global with respect to
; each of the named individual pieces, as in:
;
; PIECE-PROPS
;   (ALLNOTES (insmap (insmap-function) tempo (72) ... )
;    PIECE-NAME1 (prop1 (val) prop2 (val) ... )
;    .
;    .
;    .
;    )
;
; GLOBAL-PROPERTIES has as value a note-structure of <prop val> pairs
; that are global for all pieces in the database:
;
; GLOBAL-PROPERTIES
;   (current-piece (bach) 
;    tempo (60) 
;    sampling-rate (30000) 
;    number-of-channels (2) ... 
;    .
;    .
;    .
;    )
;
;
; the INSTRUMENTS property of UNIVERSE has as its value a note-structure data 
; structure, each one of whose properties is a name of an instrument
; whose values are themselves note-structures, and so on as shown below:
;             INSTRUMENTS
;                (insname1 (template ((start dur amp pitch fmi1 fmi2))
;                           format-properties (default-format ("~6,2F")
;                                              pitch ( ) ...      )  
;                           default-values
;                             (pitch (8.00) dur (1) stereo (.5) ... )
;                           )
;                 insname2 (template ( ... )
;                           format-properties (default-format ( ) ... 
;                           default-values ( ... )
;                           )
;                 )
;
; The information under INSTRUMENTS is of course that which is peculiar
; to each individual instrument, such as the template (list of parameters
; for that instrument), the proper format for printing each
; of the instrument's parameters, and default values for each of
; the instrument's parameters.

; --------------- * ACCESSORS AND UPDATERS * ---------------------------
; for UNIVERSE database described above.

; For each property in the data-structure there will be a
; GET, ASSIGN, and PUT.

; the PIECES property of UNIVERSE has names of pieces
; as props and lists of notes as their values -- default is ALLNOTES

; PUT-PIECE appends a new note to the list under PIECES property "name"
; and returns note as its value
(defun put-piece (note &optional name)
   (if name
           (assign 'universe 'pieces
                   (putpv (car (getval 'universe 'pieces)) name note))
           (assign 'universe 'pieces
                   (putpv (car (getval 'universe 'pieces)) 'allnotes note))
    )
   note
 )

; ASSIGN-PIECE replaces old piece with one new note, returns note
(defun assign-piece (note &optional name)
   (if name
           (assign 'universe 'pieces
                   (:= (car (getval 'universe 'pieces)) name note))
           (assign 'universe 'pieces
                   (:= (car (getval 'universe 'pieces)) 'allnotes note))
    )
   note
 )

; NO-NIL utility filters off any initial nil in a list
(defun no-nil (list-of-notes)         
      (let ((first-note (car list-of-notes)))
           (if first-note list-of-notes
                          (cdr list-of-notes))))

(defun get-piece (&optional name)
   (if name
           (no-nil (getv (car (getval 'universe 'pieces)) name))
           (no-nil (getv (car (getval 'universe 'pieces)) 'allnotes))
    )
 )

  
; ------------------  * PIECE-PROPS  * ------------------------
; the PIECE-PROPS property of UNIVERSE has a note-structure
; as its value with names of pieces as the 
; properties, which in turn have various properties
; whose values may be peculiar to that particular entire piece.
;
; One such property is INSMAP, used for MIDI output, possibly
; to a number of synthesizers at once, each with a different number of channels.
; INSMAP may be an assoc list like '((1 1) (2 1) (3 1) (4 2) ... (99 16))
; which maps insnos to MIDI channels (max 16).
; The value of (GET-INSMAP name) may also be the name of a defined function.
;
; KTOA-INS (in MIDI.LSP) should take MIDI-channel from INSMAP.
; If insno not in INSMAP, there should be a default in KTOA-INS.
; Get INSMAP by (GET-INSMAP piece-name)    
; GET-INSMAP looks at 'ALLNOTES if no piece-name.
; If no insmap for piece or for allnotes,
; GET-INSMAP should take from generic MIDI piece-prop 'MIDI.


; get- and assign- PIECE-PROP
; general facilities

; ASSIGN-PIECE-PROP assigns a value to a property for a piece-name
; in the database and returns the new value.
(defun assign-piece-prop (prop value &optional piece-name)
   ; ancillary definition   
   (labels (( assign-piece-props (piece-name value)
      (assign 'universe 
              'piece-props
              (:= (car (getval 'universe 'piece-props)) 
                   piece-name 
                   value))))
   (if piece-name
       (assign-piece-props piece-name
                           (:= (car (get-piece-props piece-name))
                                prop
                                value)
        )
        (assign-piece-props 'allnotes
                           (:= (car (get-piece-props 'allnotes))
                                prop
                                value)
        )
    )
   (get-piece-prop prop piece-name)
  ) )

; ancillary defun
(defun get-piece-props (&optional piece-name)
  (if piece-name
     (getv (car (getval 'universe 'piece-props)) piece-name)
     (getv (car (getval 'universe 'piece-props)) 'allnotes)))

(defun get-piece-prop (prop &optional piece-name)
   (if piece-name
       (getv (car (get-piece-props piece-name))
             prop)
       (getv (car (get-piece-props 'allnotes))
             prop)
    )
 )
; ------------------------
; get- and assign- INSMAP
(defun assign-insmap (insmap &optional piece-name)
   (assign-piece-prop 'insmap insmap piece-name))

(defun get-insmap (&optional name)
   (cond ((car (get-piece-prop 'insmap name)))
         (t (car (get-piece-prop 'insmap 'MIDI)))))

; initialize midi insmap list -- example for DX7 (only 1 channel)
;(setq midi-insmap-list 
;     '((1 1) (2 1) (3 1) (4 1) (5 1) (6 1) (7 1) (8 1)
;       (9 1) (10 1) (11 1) (12 1) (13 1) (14 1) (15 1) (16 1)))

;(assign-insmap midi-insmap-list 'MIDI)

; alternative assignment using intensional rather than extensional function:
(defun map-to-1 (x) 1)
(assign-insmap 'map-to-1 'MIDI)

; -------------- * GLOBAL-PROPERTIES * -------------------	

(defun put-global (prop value)
   (assign 'universe 'global-properties
      (putpv (car (getval 'universe 'global-properties)) prop value)
    )
   (get-global prop)
 )

(defun assign-global (prop value)
   (assign 'universe 'global-properties
      (:= (car (getval 'universe 'global-properties)) prop value)
    )
   (get-global prop)
 )

(defun get-global (prop)
   (getv (car (getval 'universe 'global-properties)) prop))

; -------------------- * INSTRUMENTS * ----------------------------

; INSTRUMENT accessors and updaters are purely accessory --
; used for TEMPLATE and FORMAT-PROPERTIES

(defun get-instrument (insname)
   (getv (car (getval 'universe 'instruments)) insname))

(defun put-instrument (insname value)
   (assign 'universe 
           'instruments
           (putpv (car (getval 'universe 'instruments)) insname value)
    )
 )

(defun assign-instrument (insname value)
   (assign 'universe 
           'instruments
           (:= (car (getval 'universe 'instruments)) 
                insname 
                value)
    )
 )
; -------------- TEMPLATE ----------------
; The template of each instrument is an ordered list of parameters
; which that instrument needs  or knows about.
; (It is like what is called an "instrument" in HMSL.)
; The template is used by procedures such as FILTER-TEMPLATE
; to massage to Lisp Kernel note structure into
; a data-structure appropriate for a particular instrument
; for Music4 or MIDI.
 
(defun put-template (insname template)
   (assign-instrument insname 
                      (putpv (car (get-instrument insname))
                             'template
                             template)
    )
   (get-template insname)
 )       

(defun assign-template (insname template)
   (assign-instrument insname 
                      (:= (car (get-instrument insname))
                          'template
                           template)
    )
   (get-template insname)
 )       

(defun get-template (insname)
   (getv (car (get-instrument insname))
         'template)
 )

; ------------------- FORMAT-PROPERTIES ---------
; These are used by procedures such as PRINT-PFIELD in PRINT4P
; to print each instrument's each parameter in an appropriate format.
; The final form by which they are accessed is procedure
; GET-PARAMETER-FORMAT and GET-DEFAULT-FORMAT (see below).

; accessories for individual format-properties
(defun assign-format-properties (insname format-list)
   (assign-instrument insname 
                      (:= (car (get-instrument insname))
                          'format-properties
                           format-list)
    )
 )

(defun get-format-properties (insname)
   (getv (car (get-instrument insname))
         'format-properties)
 )

; ------------ * individual format properties *  -----------

; ---------- ASSIGN-DEFAULT-FORMAT ----------------
(defun assign-default-format (insname format-string)
    (assign-format-properties insname
                              (:= (car (get-format-properties insname))
                                  'default-format
                                   format-string)
     )
    (get-default-format insname)
 )

(defun get-default-format (insname)
   (or (getv (car (get-format-properties insname))
             'default-format)
       (list "~6,2F"))
 )

; -------- ASSIGN-PARAMETER-FORMAT ------------------
; assign individual format strings to each parameter for each instrument
(defun assign-parameter-format (insname parameter format-string)
    (assign-format-properties insname
                              (:= (car (get-format-properties insname))
                                   parameter
                                   format-string)
     )
     (get-parameter-format insname parameter)
 )

(defun get-parameter-format (insname parameter)
   (or (getv (car (get-format-properties insname))
          parameter)
       (get-default-format insname)
    )
 )


;     Function for assigning parameter formats to more than
;     one parameter at a time; can be separate arguments or a list
(defun assign-parameter-formats (insname &rest pairlist)
    (let ((item (car pairlist)))
      (if (listp item) (setq pairlist item)) 
      (do* ((pairs pairlist (cddr pairs))
	     (parameter (car pairs) (car pairs))
	     (format-string (cadr pairs) (cadr pairs))
	     )
            ((not parameter) t)
            (assign-parameter-format insname parameter format-string))
     )
 )	
	
; e.g. (assign-parameter-formats 'fm 'pitch "~f6,2"
;                                    'dur "~f6,3"
;                                    'amp "~f6,0")
;
; or: (setq formats '(pitch "~f6,2" dur "~f6,3" start "~f6.1"))
;     (assign-parameter-formats 'fm formats)

   
; -------- DEFAULT-VALUES for instrument parameters ---------------
; accessories for individual default-values -- no use to user
(defun assign-default-values (insname default-list)
   (assign-instrument insname 
                      (:= (car (get-instrument insname))
                          'default-values
                           default-list)
    )
 )

(defun get-default-values (insname)
   (getv (car (get-instrument insname))
         'default-values))
 
; ---------
; These useful procedures assign
; individual default values for each parameter for each instrument.
(defun assign-default-value (insname prop default-value)
    (assign-default-values    insname
                              (:= (car (get-default-values insname))
                                   prop
                                   default-value)
     )
     (get-default-value insname prop)
 )

(defun put-default-value (insname prop default-value)
    (assign-default-values    insname
                              (putpv (car (get-default-values insname))
                                      prop
                                      default-value)
     )
     (get-default-value insname prop)
 )

(defun get-default-value (insname prop)
   (or (getv (car (get-default-values insname))
              prop)
       (list 0)
    )
 )
   


; ------------- end of UNIVERSE accessors and updaters ---------------- 




; --------------- MIXER FUNCTIONS -------------------------
; by analogy to mixing sounds  -- to use on note data not generated
; by lispfront, e.g. read in from MIDI
 
; UPDATER selects certain notes from a piece using the SELECTION PREDICATE,
; makes some change to each of those notes using UPDATE-FUNCTION,
; and returns all the notes in the piece (altered or not) as its value.
; Thus the altered piece can then be assigned over (to replace) the
; previous version of the piece, appended to it,
; or assigned to a new piece-name.
; SELECTOR-PRED should have all variables bound
; except note, e.g. (defun selector (note) (match note 'insname 'trumpet))
; UPDATE-FUNC should return the changed note as its value
; e.g. (defun update-func (note arglist) ... )

; N.B. to convert to Xlisp or Scheme must remove each mention of FUNCALL


(defun updater (piece selector-pred update-func &rest args)
        (do* ((notes (get-piece piece) (cdr notes))
              (note (car notes) (car notes)) 
              )
             ((null note) t)
             (cond ((funcall selector-pred note)
                    (put-piece (funcall update-func note args) piece))
                    (t (put-piece note piece))       
              ) 
         )
 )


(defun sample-updater (note arglist)
   (let ((pitlev (car arglist))
         )
        (:= note 'pitch (transpose (getv note 'pitch) pitlev))
    )
 )
; transposes each selected note by pitlev = first arg in &rest of updater
; n.b. function := returns altered note



; --  GET and ASSIGN-ORCH, GET-INSNAME to associate insno with insname ---

; get- and assign- ORCH
(defun assign-orch (orch &optional piece-name)
   (if (not piece-name)
       (assign-piece-prop 'orch orch 'default))
       (assign-piece-prop 'orch orch piece-name))

(defun get-orch (&optional name)
   (cond ((car (get-piece-prop 'orch name)))
         (t (car (get-piece-prop 'orch 'default)))))


; orch must be a function
; sample and default orch function assignment 
(defun map-to-fm (x) 'fm)
(assign-orch #'map-to-fm 'default)

; n.b. instrument name INSNAME is found in ORCH piece-prop as value
; for INSNO instrument number in note structure --
; always access via GET-INSNAME for data abstraction

(defun get-insname (note piece-name)
   (cond ( (functionp (get-orch piece-name))
               (funcall (get-orch piece-name) 
                        (or (car (getv note 'insno))
                            (car (getv note 'instrument)))
                )
           )
          (t  'default-insname)
     )
 )

(assign-template 'default-insname
                 '(insno start dur amp pitch))
 


; ---------- * OUTPUT UTILITIES TO SYNTHESIS SOFTWARE * -------------------


; PVFILTER re-orders <par val> pairs to fit template
; discards pars not in template
; supplies default values for pars in template that are not in note.
; To be used in PRINT-ICARD function in
; PRINT4P function (see below) for Music4P output.
; Could also be used for formatted printing of an input file
; to some other synthesis program, such as Cmix.
(defun pvfilter (note piece)
   (filter-template note piece
                    (car (get-template (get-insname note piece)))
   )
 )
 
; FILTER-GETV looks for defaults if no value found
(defun filter-getv (note prop piece)
   (or (getv note prop)
       (get-default-value (get-insname note piece) prop)
    )
 )


; FILTER-TEMPLATE does all the work for pvFILTER
(defun filter-template (note piece &optional template)
   (labels (( filter-template-aux (note piece template result)
      (if template (filter-template-aux note piece
                                        (cdr template)
                                        (cons (filter-getv note
                                                           (car template)
                                                            piece)
                                              (cons (car template)
                                                    result
                                               )
                                          )
                    )
                   (reverse result)
       )
    ))
   (if (not template) (setq template (car (get-template 'default-insname))))
   (filter-template-aux note piece template nil)
 ))


; important to evaluate this or PRINT4P won't work with notes lacking insname
; or having insname that lacks a template
(assign-template 'default-insname
                 '(insno start dur amp pitch)) 


; some reasonable default format values
(assign-parameter-format 'default-insname 'insno "~2,0f")
(assign-parameter-format 'default-insname 'start "~6,2f")
(assign-parameter-format 'default-insname 'dur "~6,2f")
(assign-parameter-format 'default-insname 'amp "~6,1f")
(assign-parameter-format 'default-insname 'pitch "~6,2f")

; examples
;(put-piece '(insno (1) start (0) dur (3) amp (100)
;             pitch (8.05)))
;(put-piece '(insno (2) start (2) dur (3) amp (100)
;             pitch (7.11) vowel (8.00 9.03)))

(assign-template  'fm '(insno start dur amp pitch fmi ratio))


; ------------- * PRINT UTILITIES * -----------------

; some very simple ones:
  
; PRINTLIST prints list without parentheses, elements each on a separate line
(defun printlist (L &optional output-stream)
   (mapcar 'print L output-stream))
 
; PRINCLIST prints items in list on a single line, separated by spaces
(defun princlist (L)
   (mapcar '(lambda (x) (princ x) (princ " ") nil)
             L))

; ---------- to save a piece to a file and retrieve it into
;            the Lisp Kernel database


 
; PRINT-PIECE prints a piece from the Kernel to a file
(defun print-piece (piecename filename)
   (with-open-file
                   (ofile filename :direction :output)
                   (print  (get-piece piecename) ofile)
    )
 )


; READ-PIECE reads a piece from a file into the Kernel
(defun read-piece (piecename filename)
   (labels (( put-piecer (note)
      (put-piece note piecename)))
   (with-open-file
                   (ifile filename :direction :input)
                   (mapcar 'put-piecer (read ifile))
    )
 ))




; ------------------- * PRINT4P functions * ------- 
; to print out file of Music4P notes from Kernel


(defun print4p (piece-name &optional filename)
   (cond ((or (eq filename t) (eq filename nil))
          (mapcar #'(lambda (note) (print-icard note piece-name filename))
                  (get-piece piece-name))
          (print-ecard filename))
         (t   (with-open-file
                   (file filename :direction :output)
                   (mapcar #'(lambda (note) (print-icard note piece-name file))
                           (get-piece piece-name))
                   (print-ecard file))
          )
    )
  )

; PRINT-ICARD prints out a Music4 "I-card" or note card-image from Kernel data.
(defun print-icard (note piece file-name)
  (let ((note (pvfilter note piece))   ; pvfilter re-orders, filters out unwanted,
                                 ; and supplies defaults. 'insno must 
                                 ; be first in template.
        (insname (get-insname note piece))
        )
     (terpri file-name) (princ 'I file-name)
     (formatf file-name 
              "~2D"
              (car (getv note 'insno)))  ; pfield 1 is anomalous
     (princ 'n file-name)                               ; NUM field
     (princ 'n file-name)
     (princ 'n file-name)
     (do* ((note (cddr note) (cddr note))   ; strip off insno par val
           (par (car note) (car note))
           (val (cadr note) (cadr note))
           (counter 2 (+ counter 1))
           )
          ((not par) t)
          (cond ((eq counter 13)
                 (setq counter (- counter 12))
                 (terpri)
                )
           )
          (print-pfield par val insname file-name))))

(defun print-pfield (par value insname file-name)
   (formatf file-name 
            (car (get-parameter-format insname par)) 
            (car value)))


; PRINT-ECARD for Music4 is ugly but works.
(defun print-ecard (filename)
   (terpri filename) (princ 'E filename)
   (let* ((ecard (car (get-global 'ecard)))
          (maxinsno (car ecard))
          (ecard (cdr ecard))
          (sr (car ecard))
          (ecard (cdr ecard))
          (nchnls (car ecard))
          (ecard (cdr ecard))
          (tape-param (car ecard))
          )
      (if (not maxinsno) (setq maxinsno 99))
      (if (not sr) (setq sr 15000.))
      (if (not nchnls) (setq nchnls 2.))
      (if (not tape-param) (setq tape-param 1.))
      (formatf filename "~2D" maxinsno)
      (princ 'n filename) (princ 'n filename) (princ 'n filename)
      (formatf filename "~6,0f" sr)
      (formatf filename "~6,0f" nchnls)
      (formatf filename "~6,0f" tape-param)))

; can implement PRINT-FCARDS if it's important to keep F-cards in the Kernel


; ------------- CSound Output * -----------------------------------------------
; These functions are for printing Csound Format note-lists
; by Rahn and Karpen


; sample header for CSound scorefile. 
; This "header" will be printed at the top of 
; the scorefile before any of the notes are printed.
(defparameter cs-header "
f 1 0 16384 10 1 0
f 2 0 2048 7 0 512 1 512 0 512 1 512 0
f 3 0 2048 7 1 512 0 512 1 512 0 512 1
f 4 0 2048 7 0 1024 1 1024 0
f 5 0 2048 7 1 1024 0 1024 1
f 99 0 2049 5 1. 2000 .01 49 .00001
")

; e.g. (printcs 'bach "bach.sco" cs-header)

(defun printcs (piece-name &optional file-name (header cs-header))
   (cond ((eq file-name t)
             (print-csheader header file-name)
             (mapcar #'(lambda (note) (print-iccard note piece-name file-name))
                     (get-piece piece-name))
             (print-eccard file-name))
          ((eq file-name nil)
               (print-csheader header t)
               (mapcar #'(lambda (note) (print-iccard note piece-name t))
                       (get-piece piece-name))
               (print-eccard file-name))
          (t
   	   (let ((x-in nil) new-file-name )
		(cond 
                  ((eq nil (open file-name :direction :probe :if-does-not-exist nil))
	     	      (with-open-file (file file-name :direction :output)
          	        (if header (print-csheader header file)) 
                          (mapcar #'(lambda (note) (print-iccard note piece-name file)) 
                                  (get-piece piece-name))
                                  (print-eccard file)
				  (princ #\newline file))
			     )
		    (t
		      (princ "File Exists: " t)  (princ file-name t) (princ #\newline t)
		      (princ "Type 1<CR> to overwrite" t) (princ #\newline t)
		      (princ "Type 2<CR> to enter new filename" t) (princ #\newline t)
		      (princ "Type any other character plus <CR> to stop" t) 
                      (princ #\newline t)
		      (princ "Enter 1,2, or a \"stop\" character:" t)
		      (setq x-in (read))
		      (cond 
                       ((= 1 x-in)
		       	   (with-open-file 
                             (file file-name :direction :output :if-exists :supersede)
          	               (if header (print-csheader header file)) 
                             	 (mapcar #'(lambda (note) (print-iccard note 
                                                                        piece-name 
                                                                        file)) 
                                         (get-piece piece-name))
                   	    	 (print-eccard file)
				 (princ #\newline file))
			)
		       (t (cond ((= 2 x-in) 
		      	   	 (princ "new file name (without quotes): " t)
			     	 (setq new-file-name (read-line))
		             	 (with-open-file (file new-file-name :direction :output)
          	                   (if header (print-csheader header file)) 
                                     (mapcar #'(lambda (note) (print-iccard note 
                                                                            piece-name
                                                                            file))  
                                             (get-piece piece-name))
                   	        	     (print-eccard file)
					     (princ #\newline file) )
			    	 )
			    )
		     	 )
		    )
		)
             )
	   )
	)
    )
)

(defun print-iccard (note piece file-name)
   (let ((note (pvfilter note piece))     ; insno must be first in template   
         (insname (get-insname note piece))
           )    
	   (cond ((not (equal nil (car (getv note 'dur))))
     		(terpri file-name) 
     		(princ "i" file-name)     
     		(do* ((noter note (cddr noter))   ; strip off instrument par val
          		 (par (car noter) (car noter))
           		(val (cadr noter) (cadr noter))
           		(counter 1 (+ counter 1))
          		 )
         		 ((not par) t)
         		 (cond ((eq counter 13)
                		 (setq counter (- counter 12))
                 		 (terpri)
                		 )
           		  )
         		  (print-icpfield par val insname file-name))
			)
		)
	)
)


(defun print-icpfield (par val insname file-name)
   (format file-name (car (get-parameter-format insname par)) (car val)) 
   (princ " " file-name))

(defun print-eccard (file-name)
   (terpri file-name)
   (princ "e" file-name))

(defun print-csheader (header filename)
   (terpri filename)
   (princ header filename))


; For Printing Csound Function (F) cards (rsk)
; USE print-csheader INSTEAD OF THIS FUNCTION!!!!!
(defun print-fccards (file-name funcs)
		(do* ((i 0 (+ i 1))) ((= i (list-length funcs)))
		    (terpri file-name)
		    (princ "f" file-name)
		    (do* ((j 0 (+ j 1))) 
                         ((= j (list-length (nth i funcs))))
	    	    (format file-name "~f ~a" (nth j (nth i funcs)) #\Space))
		 )
 )


; **************************************************************************
;
;		FOR PRINTING MUSIC KIT SCORE FILES
;		      by Karpen and Rahn
;
; **************************************************************************


(defun printmk (piece-name &optional file-name header)
   (cond ((or (eq file-name t) (eq file-name nil))
          (print-MKheader header file-name)
          (mapcar #'(lambda (note) (print-PMKcard note piece-name file-name))
                  (get-piece piece-name))
          (print-MKEcard file-name))
         (t
   	   (let ( (x-in nil) new-file-name )
		(cond ( (equal nil (open file-name :direction :probe :if-does-not-exist nil) )		
			(with-open-file (file file-name :direction :output)
          	   	 	(if header (print-MKheader header file) )
                   		 (mapcar #'(lambda (note) (print-PMKcard note 
                                                                         piece-name 
                                                                         file)) 
                                         (get-piece piece-name))
          	   		 (print-MKEcard file)
				 (princ #\newline file))
			    )
			    (t
	     	  		(princ "File Exists: " t)  (princ file-name t) (princ #\newline t)
		   		(princ "Type 1<CR> to overwrite" t) (princ #\newline t)
		  		(princ "Type 2<CR> to enter new filename" t) (princ #\newline t)
		   		(princ "Type any other character plus <CR> to stop" t) (princ #\newline t)
		   		(princ "Enter 1,2, or a \"stop\" character:" t)
		   		(setq x-in (read))
		   		(cond ( (= 1 x-in)
		        			(with-open-file (file file-name :direction :output :if-exists :supersede)
          	   	    		 		(if header (print-MKheader header file) )
                   	    		 		(mapcar #'(lambda (note) (print-PMKcard note piece-name file)) (get-piece piece-name))
          	   	    		 		(print-MKEcard file)
							(princ #\newline file))
				 		)
		   				(t (cond 	( (= 2 x-in) 
		 	      			  		(princ "new file name (without quotes): " t)
			    			 		(setq new-file-name (read-line))
		             			 	 	(with-open-file (file new-file-name :direction :output)
          	   	         			 			(if header (print-MKheader header file) )
                   	         			 			(mapcar #'(lambda (note) (print-PMKcard note piece-name file)) 
																																		                          			 (get-piece piece-name))
          	   	         			 			(print-MKEcard file)
										(princ #\newline file)  )
			    			 		)
			  				)
		     				)
		    	 	 	)
		      	   	)
                  	)
		)
	    )
	)
)



; **************************************************************************
; The first three parameters in the template for music kit instuments must be as follows:
; (insno start dur ... )
; **************************************************************************
		    
		    
(defun print-PMKcard (note piece file-name)
   (let ((note (pvfilter note piece))   ; pvfilter re-orders, filters out unwanted,
                                 ; and supplies defaults. 'instrument must 
                                 ; be first in template.
           (insname (get-insname note piece))
     	)
     (cond ( (not (equal nil (car (getv note 'dur)))) 
     		(terpri file-name) 
     		(print-IMKstart (getv note 'start) insname file-name)
     		(terpri file-name) 
    		(princ insname file-name)  
    	 	(print-IMKdur (getv note 'dur) insname file-name)
     		(do* ((noter (cdddr (cdddr note)) (cddr noter))   ; strip off instrument par val
          	 	(par (car noter) (car noter))
           		(val (cadr noter) (cadr noter))
          	 	(counter 1 (+ counter 1))
          	 	)
          		((not par) t)
         		(if (eq counter 7) 
		   	   (progn
                		(setq counter (- counter 6))
                		(terpri file-name)
               	     	    )
           		)
          		(print-IMKpfield par val insname file-name)
        	)
        	(princ ";" file-name)
      	 )
      )
    )
 )


; *******************************************
; This is for printing out all the MusicKit 
; header info. The header must include the 
; "BEGIN;" statement, but can also include 
; anything after the BEGIN which is compatible 
; with music kit scorefile syntax.
; *******************************************

(defun print-MKheader (header filename)
   (terpri filename)
   (princ header filename))


(defun print-IMKpfield (par val insname file-name)
   (princ (car (get-mkprintname insname par))  file-name)
   (format file-name (car (get-parameter-format insname par)) (car val))
   (princ  " " file-name))

(defun print-IMKdur (dur insname file-name)
   (princ "(" file-name)
   (format file-name (car (get-parameter-format insname 'dur)) (car dur))
   (princ ") " file-name))

(defun print-IMKstart (start insname file-name)
   (princ "t " file-name)
   (format file-name (car (get-parameter-format insname 'start)) (car start))
   (princ ";" file-name))

(defun print-MKEcard (file-name)
   (terpri file-name)
   (princ "END;" file-name))

; ------------------- Music Kit Parameter Printnames --------------

; These are used by procedures such as PRINT-MKPFIELD in PRINTMK
; to print an appropriate Music Kit name for each instrument's each parameter.
; The final form by which they are accessed is procedure
; GET-MKPRINTNAME and ASSIGN-MKPRINTNAME (see below).

; accessories for individual format-properties
(defun assign-mkprintnames (insname mkprintname-list)
   (assign-instrument insname 
                      (:= (car (get-instrument insname))
                          'mkprintnames
                           mkprintname-list)
    )
 )

(defun get-mkprintnames (insname)
   (getv (car (get-instrument insname))
         'mkprintnames)
 )

; ------------ * individual parameter printnames *  -----------

; ---------- ASSIGN-DEFAULT-PRINTNAME ----------------
(defun assign-default-mkprintname (insname mkprintname)
    (assign-mkprintnames      insname
                              (:= (car (get-mkprintnames insname))
                                  'default-mkprintname
                                   mkprintname)
     )
    (get-default-mkprintname insname)
 )

(defun get-default-mkprintname (insname)
   (or (getv (car (get-mkprintnames insname))
             'default-mkprintname)
       (list "|default-name:|"))
 )

; -------- ASSIGN-MKPRINTNAME
; assign an individual print name to each parameter for each instrument
(defun assign-mkprintname (insname parameter printname)
    (assign-mkprintnames      insname
                              (:= (car (get-mkprintnames insname))
                                   parameter
                                   printname)
     )
     (get-mkprintname insname parameter)
 )

; e.g. (assign-mkprintname 'kzu 'amp "amp: ")


(defun get-mkprintname (insname parameter)
   (or (getv (car (get-mkprintnames insname))
              parameter)
       (get-default-mkprintname insname)
    )
 )




;     Function for assigning printnames to more than
;     one parameter.
(defun assign-all-printnames (insname &rest pairlist)
       (do* ( (pairs pairlist (cddr pairs))
	    (par (car pairs) (car pairs))
	    (name (cadr pairs) (cadr pairs))
	)
        ((not par) t)
        (assign-mkprintname insname par name)))   
	
	
; e.g. (assign-all-printnames 'fm 'fmi "Index: " 
;                                 'ratio "Ratio: "
;                                 'pitch "Freq: ")

; ********************************************************************
;
;    Sample Music Kit header and templates
;     e.g. (printmk 'bach "bach.score" mk-header)
;
; ******************************************************************

(defparameter mk-header 
"info samplingRate:44100.00000, tempo:60;
part P1;
part P2;
part P3;
part P4;
part P5;
part P6;

envelope ampFn14  =  [(0,3)(.1,.5)(.22,.0)|(1.,0)];
envelope indFn14  =  [(0,1)(.04,2)(.1,3)(.25,3)(.5,5.25)(.75,.35)(1,.2)];
envelope frqFn14  = [(0,.97)(.02,1.01)(.04,.995)(.06,1)(.8,1.1)|(1,.98)];
waveTable fl2 = [{1,1}];


P1 synthPatchCount:1, synthPatch:\"Pluck\";
P3 synthPatchCount:1, synthPatch:\"Pluck\";
P5 synthPatchCount:1, synthPatch:\"Pluck\";
P2 synthPatch:\"Fm1vi\" synthPatchCount:1 rvibAmp:0;
P4 synthPatch:\"Fm1vi\" synthPatchCount:1 rvibAmp:0;
P6 synthPatch:\"Fm1vi\" synthPatchCount:1 rvibAmp:0;

BEGIN;

")







;*******************   functions for Gold Hill CL ****************************
; -------------------------------------------------------------
; ----------------- * FORMATF function * ----------------------
; Common Lisp FORMAT function substitute written by Larry Stamper 8/88
; for Lisp Kernel to Music4P or other formatted output
;	
; This was written because Gold Hill Common Lisp 2.2 does not implement
; FORMAT for floating-point numbers. If you are using a full Common Lisp
; you will probably want to replace all uses of FORMATF with FORMAT.

; PUSH-DIGITS
; preconditions : Number is a floating-point number.
;		  Places is an integer.
; returns       : a stack of the characters in the decimal representation of
;                 Number, pushed in reverse order.
; side effects  : none
; comments      : used in write-float.

(defun push-digits (number places)
 (do ( (stack 
        (make-array 32 :element-type 'character :fill-pointer 0))
       (n 
        (round (* (abs number) (expt 10.0 (max 0 places))))
        (truncate n 10))
       (power-of-10 
        (min 0 (- places))
        (1+ power-of-10)) )

     ( (and (>= power-of-10 0) (eql n 0)) 
       (if (minusp number) (vector-push #\- stack))
       stack )

     (vector-push (+ 48 (mod n 10)) stack)
     (if (eql power-of-10 -1) (vector-push #\. stack)) ) )



; WRITE-FLOAT
; preconditions : Stream is an active output stream.
;		  Number is a floating-point number.
;		  Field-width and Places are integers.
; returns       : nil
;                 
; side effects  : The decimal representation of Number is printed to Stream
; comments      : used by formatf.

(defun write-float (stream number field-width places)
 (let  ( (stream (cond ((eql stream t) *standard-output*) (t stream)))
         (digit-stack
          (cond
            ((and (eql (float number) 0.0) (eql places 0))
              (make-array 
                1 
                :element-type 'character 
	        :initial-element #\0
                :fill-pointer 1))
            ((or (and (plusp number)
                      (> (+ 1 (floor (log number 10))) field-width))
	         (and (minusp number)
                      (> (+ 2 (floor (log (- number) 10))) field-width)))  
              (make-array 
                field-width 
                :element-type 'character 
	        :initial-element #\*
                :fill-pointer field-width))
            (t 
	      (push-digits 
	       number 
               (min 
                 places
                 (cond 
                    ((>= number 1) (- field-width (floor (log number 10)) 2))
	            ((>= number 0) (- field-width 1))
                    ((>= number -1) (- field-width 2))
                    (t (- field-width (floor (log (- number) 10)) 3)))))) )))

       (cond
         (stream
           (dotimes (index (- field-width (length digit-stack)))
 	  	 (write-char #\Space stream))
           (dotimes (index (length digit-stack))
	 	 (write-char (vector-pop digit-stack) stream)))
         (t (coerce (reverse (coerce digit-stack 'list)) 'string)))))



; FORMATF
; preconditions : Stream is an open output stream.
;		  Control-string is a string whose second and fourth characters
;                 are digits.
;		  Number is a floating-point number.
; returns       : nil
; side effects  : Same as function write-float with arguments
;                 Stream, Number, and the integers represented by the second 
;                 and fourth characters in Control-string.
; comments      : Formatf is not a true format function. It is basically just a
;                 function to write a floating point number with control over
;                 field-width and decimal places. This is all done by the 
;                 helper function write-float. Then formatf does some cosmetic
;                 surgery on write-float, so that a call to formatf resembles
;		  a call to the built-in function format.
;                 Example :  (formatf filehandle "~6,2F" value) is equivalent
;                         to (write-float filehandle value 6 2)
;                 Everything in the control-string other than the second and
;		  fourth characters is ignored. This makes formatf more limited
;		  than write-float, because formatf can only pass along a
;                 field-width or decimal-places argument between 0 and 9.
; warning       : This function should only be used is to print a single
;		  floating-point number to a stream with specified field-width
;                 and places. If you forget and try use it as if it were a
;		  general formatting function, you will get an error message.


;(defun formatf (stream control-string number)
; (cond
;   ((and (eql (length control-string) 5)
;         (eql #\~ (aref control-string 0))
;         (digit-char-p (aref control-string 1))
;         (eql #\, (aref control-string 2))
;         (digit-char-p (aref control-string 3))
;         (eql #\F (char-upcase (aref control-string 4))))
;      (write-float 
;      stream 
;      number
;      (- (char control-string 1) 48)
;      (- (char control-string 3) 48) ))
;    (t (error "FORMATF -- 2nd arg must be a 5-character string whose 2nd and 4th characters~%    ;       are decimal digits, with 1st character ~~, third character ., and~%           fifth character F or f."))))  
;; example: (formatf filehandle "~6.2F" value) prints value as 
; field width 6, mantissa 2 floating point		
;(formatf t "~6.6f" pi)

;  --------  ** implementation note ** ---------------
; If you are using Gold Hill 2.2, comment out the following
; FORMATF defun so that the previous defun will take effect.
; Else, the following simply redefines FORMATF as CL FORMAT.
(defun formatf (stream control-string number)
   (format stream control-string number))

; --------- end FORMATF -------------------------------------------------------



; -------------------------------------------------------------
; ------------------------- MIDI.LSP -------------------------
; --------------------------------------------------------------

; MIDI.LSP MIDI interface for the Lisp Kernel
; written by Larry Stamper, 9/88
; uses C MIDI Toolkit as intermediary.
; This version was developed on an IBM AT with a Roland MPU401 MIDI
; card, under Gold Hill Common Lisp version 2.2.
; It has been modified to work under KCL or any vanilla Common Lisp.
; To use the Gold Hill version, load GHMIDI.LSP after loading this file.

; The MIDI utilities here provide
; translation between kernel and adagio (CMT) file formats, along with
; (for Gold Hill IBM AT version only)
; sys:dos calls to the CMT programs ADAGIO  and TRANSCRIBE to provide a
; simple interface from midi to the lisp kernel.

; N.B. ATOK = Adagio TO Kernel    KTOA = Kernel TO Adagio



; ------------------- HIGH-LEVEL FUNCTIONS -------------------


; MIDI-IN
(defun midi-in (file-name &optional piece-name)
;   (transcribe)             ; system calls to read MIDI events into an Adagio file
   (load-from-adagio file-name piece-name))

; example: (midi-in "my_piece" 'masterpiece) creates and reads MIDI in to
; a file named "my_piece.gio", then reads the file into the Kernel
; as piece named "masterpiece" which is accessed with
; (get-piece 'masterpiece).

; The file name must be a string, no suffix;
; The piece name is for the internal Lisp Kernel database.
; Example: (midi-in "piece" 'ugly)
; You will be prompted for the file name again: piece
; (no quotes, no suffix)




; MIDI-OUT
(defun midi-out (file-name &optional piece-name)
   (save-to-adagio file-name piece-name)
   ;(adagio)    ; system calls to play the adagio file out to a MIDI device
)

; Example: (midi-out "bach" 'bach)
; You will again be prompted for the name of the Adagio file: bach
; (no quotes, no suffix). The resulting file is called bach.gio.

; --------------------------------------------------------------


; LOAD-FROM-ADAGIO
; precondition : File is a legal pathname which names an adagio file, in the
;		 format of a file created by the program ADAGIO in CMT or a
;		 call to the function adagio in the kernel, which is the same
;		 thing. NOTE: this function will NOT work on all legal adagio
;		 files -- only the format specified above.
;		 Piece-name is a symbol.
; returns      : nil.
; side effects : removes any piece attached to piece-name.


(defun load-from-adagio (filename &optional piece-name)
  (clear-notes piece-name)
  (atok-translate 
     (append-filename-suffix filename "gio")
     piece-name))


; SAVE-TO-ADAGIO
; precondition : filename is a legal pathname.
;		 Piece-name is a symbol.
; returns      : nil.
; side effects : Overwrites (or creates and writes) an adagio file named by
;                filename with the adagio representation of the piece indicated
;		 by piece-name.

(defun save-to-adagio (filename &optional piece-name)
  (ktoa-translate (append-filename-suffix filename "gio") piece-name))


; TRANSCRIBE
; precondition : none
; returns      : nil
; side effects : executes the CMT program TRANSCRIBE.
; remarks      : The program Transcribe takes input in the form of midi data
;                (typically, the midi representation of music you play on a
;                synthesizer), and translates it into the music language
;                Adagio. Inside Transcribe, you will be prompted for the
;                name of the file in which you want to store this Adagio
;		 description of your music. Then you will be asked whether
;                or not you want Transcribe to record continuous controller
;                data. The prompt will be:
;                    Pitch bend, etc. on ? [n]:
;                As far as the lisp kernel is concerned, it doesn't matter what
;		 you type, since the translation from midi to kernel (see
;		 LOAD-FROM-ADAGIO) ignores continuous controller information.
;		 So you might as well just hit return, which will give the
;                default value of NO.
;           
;(defun transcribe ()
;  (sys:exec "\\cmt\\transcribe.exec"))


; ADAGIO
; precondition : none
; returns      : nil
; side effects : executes the CMT program ADAGIO.
;(defun adagio ()
;  (sys:exec "\\cmt\\adagio.exec"))



; GENERAL UTILITY FUNCTIONS

; PROMPT-STRING
; precondition : prompt-msg is a string.
; returns      : a string from *standard-input*.
; side effects : prompt-msg is written to *standard-output*.

(defun prompt-string (prompt-msg)
  (prog2
    (format t "~%~A " prompt-msg)
    (read-string *standard-input*)
    (terpri)))

;PEEK-CHAR
; This is supplied in the CL standard, but not in Gold Hill 2.2
;(defun peek-char (stream)
; (let ((char (read-char stream nil nil)))
;  (if char (unread-char char stream))
;  char))

; READ-STRING
; precondition : input-stream, if present, is either nil or an 
;                active input stream.
; returns      : a string consisting of the first n consecutive non-whitespace
;                characters read from input-stream, where 0 <= n <= 80.
;		 An empty string (n = 0) occurs when end-of-file is reached
;	         without any non-whitespace characters having been read.
; side effects : all characters on input-stream up to and including the last 
;                character put into the return string are consumed.
;                if input-stream is absent or equal to *standard-input*, all
;		 characters consumed from *standard-input* are echoed to 
;		 *standard-output*.

(defun read-string (&optional input-stream)
  (do 
    ( ( char 
        (read-char-skip-whitespace input-stream) 
        (read-char input-stream nil nil) )
      ( string (make-array 80 :element-type 'character :fill-pointer 0)) )
    ( (or (null char) (< char  33) (> char 126) (= (length string) 80))
      (cond
        ((eql (length string) 0) nil)
        (t (coerce string 'string))) )
    (vector-push char string)
    (if (or (null input-stream) (equal input-stream *standard-input*))
        (write-char char) )))

; must defun array-length for this to work
(defun read-string-preserve-whitespace (&optional input-stream)
  (do 
    ( ( char 
        (read-char-skip-whitespace input-stream) 
        (read-char input-stream nil nil) )
      ( string (make-array 80 :element-type 'character :fill-pointer 0)) )
    ( (or (null char) (< char  33) (> char 126) (= (array-length string) 80))
     (if char (unread-char char input-stream))
      (coerce string 'string) )
    (vector-push char string)
    (if (or (null input-stream) (equal input-stream *standard-input*))
        (write-char char) )))
	  

; APPEND-FILENAME-SUFFIX   is not implemented
; precondition : filename and suffix are strings
; returns      : a string consisting of filename concatenated with "." and
;                suffix. If filename already contained a period the period and
;                all subsequent characters in filename are removed before
;		 concatenation.
; side effects : none
;(defun append-filename-suffix (filename suffix)
;  (do ((index 0 (1+ index)))
;      ((or (eql index (length filename)) (eql (char filename index) #\.)) 
;         (string-append (subseq filename 0 index) "." suffix))))
; string-append is not in Steele's standard

;;; 

; READ-CHAR-SKIP-WHITESPACE
; precondition : file is an active input stream.
; returns      : the first non-whitespace character in file, or nil if eof is 
;	         reached before any such character is read.
; side effects : all characters in file up to the character returned are 
;		 consumed. If nil is returned, file was completely consumed.
 
(defun read-char-skip-whitespace (file)
 (do
   ((char (read-char file nil nil) (read-char file nil nil)))
   ((or (null char) (>= char  33) (<= char 126)) char)))




; SPLIT-AUX
; precondition : L1 and L2 are lists.
; returns      : If L2 is the same length as or shorter than L1, a list
;                consisting of L1 and L2 is returned. Otherwise, returns
;		 the result of recursively calling split-aux on L1 with
;		 the car of L2 appended to it, and the cdr of L2.
; side effects : none.

(defun split-aux (L1 L2)
 (cond
  ((<= (length L2) (length L1)) (list L1 L2))
  (t (split-aux (append L1 (list (car L2))) (cdr L2)))))



; SPLIT
; precondition : L is a list.
; returns      : A list consisting of two lists which are the ordered elements
;		 of L split into two equal (or nearly equal) halves. If L has 
;		 an odd number of elements, then the first list has one more 
;		 element than the second. Otherwise they are of equal length.
; side effects : none.
(defun split (L)
 (split-aux nil L))

; MERGE
; precondition : L1 and L2 are lists. 
;                Keyfunc, if present, is the name of a function which, when
;		 called on an element of L1 or L2, returns a value to be used
;		 for ordering.
;                Comparison is the name of an ordering function which takes two
;		 values and returns t if the values are in order or nil if they
;		 are not.
;                L1 and L2 are lists whose elements are in order according to
;		 the function Comparison as applied to the value returned by
;		 the function Keyfunc, if Keyfunc is present, or the elements
;		 themselves otherwise.
; returns      : a list containing all of the elements of L1 and L2 in sorted
;		 order.
; side effects : none.

(defun our-merge (L1 L2 comparison &optional keyfunc)
 (cond
  ((null L1) L2)
  ((null L2) L1)
  ((funcall 
     comparison
     (if keyfunc (funcall keyfunc (car L1)) (car L1))
     (if keyfunc (funcall keyfunc (car L2)) (car L2)))
   (cons (car L1) (our-merge (cdr L1) L2 comparison keyfunc)))	
  (t (cons (car L2) (our-merge (cdr L2) L1 comparison keyfunc)))))	


; MERGESORT
; precondition : Comparison is the name of an ordering function which takes two
;		 arguments and returns t if they are in order, and nil
;		 otherwise.
;		 Keyfunc is the name of a function that takes one argument and
;		 returns a value to be used for ordering.
;		 L is a list whose elements can be ordered according to
;		 the function Comparison applied to themselves, or, if Keyfunc
;		 is present and not nil, applied to the results of applying
;		 Keyfunc to the elements.
; returns      : A list containing all of the elements of L in order according
;		 to Comparison.
; side effects : none.

(defun mergesort (L comparison &optional keyfunc)		
 (declare (special comparison keyfunc))		
 (cond					
  ((<= (length L) 1) L)			
  (t ((lambda (x) (our-merge (car x) (cadr x)  comparison keyfunc))	
      (mapcar '(lambda (y) (mergesort y comparison keyfunc)) (split L))))))


; SUPPORTING FUNCTIONS :

; Adagio to Kernel :
; translating adagio file to kernel representation


; READ-ADAG-STRING
; precondition : input-stream is an active input stream
; returns      : a string consisting of the first n consecutive non-whitespace
;                characters read from input-stream, where 1 <= n, or nil if
;		 end-of-file was reached without any non-whitespace characters 
;		 having been read.
; side effects : all characters on input-stream up to and including the last 
;                character put into the return string are consumed. If the 
;		 end-of-file was not reached, and the next character after the
;		 string is not the Newline character, then that character is
;		 consumed as well.

(defun read-adag-string (&optional input-stream)
  (do 
    ( ( char 
        (read-char-skip-whitespace input-stream) 
        (read-char input-stream nil nil) )
      ( string (make-array 10 :element-type 'character :fill-pointer 0)) )
    ( (or (null char) (< char  33) (> char 126))
      (if (equal char #\Newline) (unread-char char input-stream))
      (cond
        ((equal (length string) 0) nil)
        (t (coerce string 'string))) )
    ( vector-push char string ) ))
	  


; ATOK-PITCH
; precondition : str is a legal adagio pitch-representation
; returns      : the equivalent 8ve.pc representation
; side effects : none

(defun atok-pitch (str)
 (cond 
  ((eql (aref str 0) #\p)   
    ((lambda 
       (keynum) 
       (+ 4.00 (truncate keynum 12) (/ (rem keynum 12) 100)))
       (read-from-string (subseq str 1))))
  (t
   (+ (/ (cadr 
          (cond
           ((assoc 
             (aref str 0)
	     '( (#\a 9) (#\b 11) (#\c 0) (#\d 2) (#\e 4) (#\f 5) (#\g 7) ) ))
           (t (error str) )))
	 100)
      (case (aref str 1) (#\s .01) (#\f -.01) (t 0.0))
      (read-from-string 
        (string-left-trim "abcdefgs" str))
      4.0))))
                                    

; ATOK-AMP
; precondition : none.
; returns      : identity function for number.
; side effects : none.
	  
(defun atok-amp (number)
  number)



; ATOK-INS
; precondition : none.
; returns      : identity function for number.
; side effects : none.

(defun atok-ins (number)
  number)

; GETNOTE
; precondition : File is an open adagio file, in the format of a file created
;		 by the program ADAGIO in CMT or a call to the function adagio
;		 in the kernel, which is the same thing. NOTE: this function
;		 will NOT work on all legal representations in the adagio 
;		 language -- only the format specified above.
;		 The only previous operations on file, if any, have been prior
;		 calls to getnote itself.
; returns      : a lisp-kernel representation of a note, or nil if eof is
;		 reached.
; side effects : file is consumed up to the next Newline character or eof,
;		 whichever is first. variables timer, next, last-ins declared
;                special.

(defun getnote (file)
  (list
    'start 
    (list (/ (setq timer (+ timer next)) 100))
    'pitch 
    (list (atok-pitch
             (cond 
	       ((read-string file))
	       (t (throw 'gs nil)))))
    (progn
       (read-char-skip-whitespace file)
       'dur)
    (list (/ (read file nil nil) 100))
    (progn
       (read-char-skip-whitespace file)
       'amp)
    (list (atok-amp (read file nil nil)))
    (progn
       (read-char-skip-whitespace file)
       (setq next (read-from-string (read-string file)))
       'insno)
    (list (atok-ins
	    (cond 
	      ((eql (peek-char file) #\v) 
                 (read-char file nil nil)
                 (read file nil nil))
              (t last-ins))))))
 


; GET-SEQUENCE
; precondition : File is an open adagio file, in the format of a file created
;		 by the program ADAGIO in CMT or a call to the function adagio
;		 in the kernel, which is the same thing. NOTE: this function
;		 will NOT work on all legal representations in the adagio 
;		 language -- only the format specified above.
;		 Piece-name is a symbol.
; returns      : nil.
; side-effects : a new note-list consisting of all the notes in file is the new
;                value of the symbol piece-name in the pieces property of 
;		 universe in the lisp-kernel.
;		 file is consumed.

(defun get-sequence (file &optional piece-name)
  (catch 'gs
    (let ( (timer 
	    (cond 
	      ((eql #\t (peek-char file)) (read-char file) (read file))
              (t 0)))
	   (next 0)
	   (last-ins 1) )
         (declare (special timer next last-ins))
         (loop
	  (cond
            ((null (peek-char file)) (throw 'gs nil))
            ((member (peek-char file) '(#\a #\b #\c #\d #\e #\f #\g #\p))
              (put-piece
	       (getnote file)
               piece-name))
            (t 
              (read file) 
	      (read-char-skip-whitespace file)
	      (setq next (+ next (read file)))))))))


; ATOK-TRANSLATE
; precondition : filename is a string
; returns      : nil
; side effects : same as get-sequence, which is called in atok-translate.

(defun atok-translate (filename &optional name)
  (with-open-file
    (file filename)
    (get-sequence file name)))


; Kernel to Adagio :
; translating kernel to adagio file representation



; KTOA-PITCH
; precondition : number is a legal pitch-representation in 8ve.pc
; returns      : equivalent adagio representation
; side effects : none

(defun ktoa-pitch (number)
  ((lambda (x) (cond ((minusp x) (mod x 12))
		     ((and (> x 127) (= (mod (- x 127) 12) 0)) 127)
                     ((> x 127) (+ (- 127 12) (mod (- x 127) 12)))
                     (t x)))
   (+ (* (- (truncate number) 4) 12)
      (mod (round (* number 100)) 100))))


; KTOA-AMP
; precondition : none.
; returns      : identity function for number.
; side effects : none.

(defun ktoa-amp (number)
  (round number))


; KTOA-INS
; precondition : number is between 0 and 99.
; returns      : a midi channel according to a specified mapping or function.
; side effects : none.
(defun ktoa-ins (number &optional piece-name)
  (let ((insmap (get-insmap piece-name)))
   (cond ((null insmap)
         (if (zerop (rem number 16)) 
              16
              (mod number 16)))
         ((atom insmap) (funcall insmap number))
         (t (cadr (assoc number insmap))))))

; insmap is either the name of a function or an association list
; like '((1 1) (2 1) (3 1) (4 2) ... (99 16))
; maps insnos to MIDI channels (max 16)
; ktoa-ins should take MIDI-channel from insmap
; if insno not in insmap, default channel
; get insmap by (get-insmap piece-name)    ; if none for piece,
; get-insmap should take from MIDI-default note-structure 'insmap-default
; get-insmap should also look at 'allnotes if no piece-name
; IMPROVEMENTS -- this should be done for other conversions as well -- pitch,
;                 amplitude, etc., in both directions (atok and ktoa).



; KTOA-INS-1
; precondition : none
; returns      : 1
; side effects : none (number never used)
(defun ktoa-ins-1 (number)
  1)



; KTOA-DUR
; precondition : number is a number.
; returns      : number times 100.
; side effects : none.
(defun ktoa-dur (number)
  (round (* 100 number)))


; PUTNOTE
; precondition : note is a note-list containing values for the five properties
;		 instrument, start, dur, amp and pitch.
; returns      : nil
; side effects : Prints the adagio representation of note on one line in file.

(defun putnote (note next-note file &optional piece-name)
 (progn
  (write-char #\p file)
  (prin1 (ktoa-pitch (car (getv note 'pitch))) file)

  (write-char #\Space file)   (write-char #\u file)
  (prin1 (ktoa-dur (car (getv note 'dur))) file)

  (write-char #\Space file)   (write-char #\l file)
  (prin1 (ktoa-amp (car (getv note 'amp))) file)

  (write-char #\Space file)   (write-char #\n file)
  (prin1 
    (ktoa-dur (- (car (getv next-note 'start)) (car (getv note 'start))))
    file)

  (write-char #\Space file)   (write-char #\v file)
  (prin1 (ktoa-ins (car (getv note 'insno)) piece-name) file)
  (write-char #\Newline file)))



; PUT-SEQUENCE
; precondition : notes is a list of note-lists
; returns      : nil
; side effects : prints the adagio representation of notes in file.

(defun put-sequence (notes file &optional piece-name)
  (do ( (seq notes (cdr seq)) )
      ( (null seq) )
      ( cond
          ((null (cdr seq)) (putnote (car seq) (car seq) file piece-name))
	  (t (putnote (car seq) (cadr seq) file)) ) ))



; KTOA-TRANSLATE
; precondition : filename is a legal pathname.
;		 name, if present, is a symbol.
; returns      : nil.
; side effects : The list of notes associated with name is printed to a file
;		 with pathname filename in adagio representation.

(defun ktoa-translate (filename &optional piece-name)
  (with-open-file
    (file filename :direction :output)
      (put-sequence 
        (mergesort 
          (get-piece piece-name)
          '<=
          '(lambda (x) (car (getv x 'start))))
        file
	piece-name)))

(defun score-sort (piece-name new-piece)
   (mapcar #'(lambda (piece) (put-piece piece new-piece) )
	(mergesort (get-piece piece-name) 
		'<=
		'(lambda (x) (car (getv x 'start))))
	)
)



; **************** END FUNCTIONS FOR GOLD HILL CL ********************



; --------------------------------------------------------------------------
;*******************************
;Taken from the NeXT Lisp Scorefile Package
;*******************************

(defun eval-car (expr)
  (eval (car expr)))

; lookup is like gen 7 -- straight line segments
; index is position; values is assoc list ((position value) 
;                                           (pos2 val2)...)
;returns value linearly extrapolated for index position									       
(defun lookup (index values)
  (let ((i1 (if (numberp index) 
                (position index values :key #'eval-car :test #'>= :from-end t)
              (unless (or (eq index :r) (eq index :end))
                (error "Non-numeric index ~a to lookup or env" index)))))
    (cond ((not i1)
           (eval (cadar values)))
          ((= i1 (- (length values) 1))
           (eval (cadar (last values))))
          (t
           (let* ((xy1 (nth i1 values))
                  (xy2 (nth (+ i1 1) values))
                  (x1 (eval (first xy1)))
                  (y1 (eval (second xy1))))
             (+ y1 (* (- (eval (second xy2)) y1) 
                      (/ (- index x1) (- (eval (first xy2)) x1)))))))))



; ***********************************************************
; Rahn's modifications

; table = lookup is like gen 7 -- straight line segments
; index is position; values is assoc list ((position value) 
;                                           (pos2 val2)...)
;returns value linearly extrapolated for index position			       

; table1 is like oscil1 -- puts out last value if index exceeds interval
(defun table1 (index values)
  (let ((i1 (if (numberp index) 
                (position index values :key #'eval-car :test #'>= :from-end t)
              (unless (or (eq index :r) (eq index :end))
                (error "Non-numeric index ~a to lookup or env" index)))))
    (cond ((not i1)
           (eval (cadar values)))
          ((= i1 (- (length values) 1))
           (eval (cadar (last values))))
          (t
           (let* ((xy1 (nth i1 values))
                  (xy2 (nth (+ i1 1) values))
                  (x1 (eval (first xy1)))
                  (y1 (eval (second xy1))))
             (+ y1 (* (- (eval (second xy2)) y1) 
                      (/ (- index x1) (- (eval (first xy2)) x1)))))))))

; table is like oscil -- recycles
(defun table (index values)
  (let* ((lastval (car (car (last values))))
	(index (mod index lastval))
	(i1 (if (numberp index) 
                (position index values :key #'eval-car :test #'>= :from-end t)
              (unless (or (eq index :r) (eq index :end))
                (error "Non-numeric index ~a to lookup or env" index)))))
    (cond ((not i1)
           (eval (cadar values)))
          ((= i1 (- (length values) 1))
           (eval (cadar (last values))))
          (t
           (let* ((xy1 (nth i1 values))
                  (xy2 (nth (+ i1 1) values))
                  (x1 (eval (first xy1)))
                  (y1 (eval (second xy1))))
             (+ y1 (* (- (eval (second xy2)) y1) 
                      (/ (- index x1) (- (eval (first xy2)) x1)))))))))

; for values in table, e.g.
;; ramp and tent tables for use later
(defconstant dirac '((0 0) (1 1)))  ;ramp
(defconstant tent '((0 0) (.5 1) (1 0)))
(defconstant V '((0 1) (.5 0) (1 1)))  ; NB capital "V", inverse tent
 
;-----------end rahn alternatives to Music Kit Scorefile Package funcs---
 
;***************************************
; Some Karpen additions
;***************************************

(defun cycle (index inlist) 
	(eval (nth (mod index (list-length inlist)) inlist))
)

(defun seq (index inlist)
	(cond ((< index (length inlist))
			(nth index inlist))
		    (t (nth (- (length inlist) 1) inlist))
		)
)

(defun init-random-state (seed)
  (setq *random-state* 
    (read-from-string (format nil "#s(RANDOM-STATE :SEED ~d)" seed))))

(defconstant a0 27.5)
(defconstant as0 29.14)
(defconstant b0 30.87)
(defconstant c1 32.7)
(defconstant cs1 34.65)
(defconstant d1 36.71)
(defconstant ds1 38.89)
(defconstant e1 41.2)
(defconstant f1 43.65)
(defconstant fs1 46.25)
(defconstant g1 49.99)
(defconstant gs1 51.91)
(defconstant a1 55.00)
(defconstant as1 58.27)
(defconstant b1 61.74)

(defconstant c2 (* 2 c1))
(defconstant cs2 (* 2 cs1))
(defconstant d2 (* 2 d1))
(defconstant ds2 (* 2 ds1))
(defconstant e2 (* 2 e1))
(defconstant f2 (* 2 f1))
(defconstant fs2 (* 2 fs1))
(defconstant g2 (* 2 g1))
(defconstant gs2 (* 2 gs1))
(defconstant a2 (* 2 a1))
(defconstant as2 (* 2 as1))
(defconstant b2 (* 2 b1))

(defconstant c3 (* 4 c1))
(defconstant cs3 (* 4 cs1))
(defconstant d3 (* 4 d1))
(defconstant ds3 (* 4 ds1))
(defconstant e3 (* 4 e1))
(defconstant f3 (* 4 f1))
(defconstant fs3 (* 4 fs1))
(defconstant g3 (* 4 g1))
(defconstant gs3 (* 4 gs1))
(defconstant a3 (* 4 a1))
(defconstant as3 (* 4 as1))
(defconstant b3 (* 4 b1))

(defconstant c4 (* 8 c1))
(defconstant cs4 (* 8 cs1))
(defconstant d4 (* 8 d1))
(defconstant ds4 (* 8 ds1))
(defconstant e4 (* 8 e1))
(defconstant f4 (* 8 f1))
(defconstant fs4 (* 8 fs1))
(defconstant g4 (* 8 g1))
(defconstant gs4 (* 8 gs1))
(defconstant a4 (* 8 a1))
(defconstant as4 (* 8 as1))
(defconstant b4 (* 8 b1))

(defconstant c5 (* 16 c1))
(defconstant cs5 (* 16 cs1))
(defconstant d5 (* 16 d1))
(defconstant ds5 (* 16 ds1))
(defconstant e5 (* 16 e1))
(defconstant f5 (* 16 f1))
(defconstant fs5 (* 16 fs1))
(defconstant g5 (* 16 g1))
(defconstant gs5 (* 16 gs1))
(defconstant a5 (* 16 a1))
(defconstant as5 (* 16 as1))
(defconstant b5 (* 16 b1))

(defconstant c6 (* 32 c1))
(defconstant cs6 (* 32 cs1))
(defconstant d6 (* 32 d1))
(defconstant ds6 (* 32 ds1))
(defconstant e6 (* 32 e1))
(defconstant f6 (* 32 f1))
(defconstant fs6 (* 32 fs1))
(defconstant g6 (* 32 g1))
(defconstant gs6 (* 32 gs1))
(defconstant a6 (* 32 a1))
(defconstant as6 (* 32 as1))
(defconstant b6 (* 32 b1))

(defconstant c7 (* 64 c1))
(defconstant cs7 (* 64 cs1))
(defconstant d7 (* 64 d1))
(defconstant ds7 (* 64 ds1))
(defconstant e7 (* 64 e1))
(defconstant f7 (* 64 f1))
(defconstant fs7 (* 64 fs1))
(defconstant g7 (* 64 g1))
(defconstant gs7 (* 64 gs1))
(defconstant a7 (* 64 a1))
(defconstant as7 (* 64 as1))
(defconstant b7 (* 64 b1))

;;------------ end karpen additions-----------------

; --------------------------------------------------------------------------
; some theory utilities                rahn 3/90

; octave from 8.ve pitch
(defun octp (arg)
   (truncate arg))

(defun pc (pitch)
    (round (* 100 (- pitch (truncate pitch)))))
    
; pc from 8ve.pc pitch
(defun pcp (arg)
   (* 100 (- arg (octp arg))))

; ordered interval between pcs 
(defun pcint (pc1 pc2)
   (mod (- pc2 pc1) 12))

; ordered interval between 8ve.pc pitches
; NB to get integral value :round? t (default is nil)
; to get full value :round? nil
(defun pitchint (p1 p2 &key (ets 12) (round? nil))
   (let* ( (octave1 (truncate p1))    
           (octave2 (truncate p2))
	   (pc1 (* 100. (- p1 octave1)))  
           (pc2 (* 100. (- p2 octave2)))
	   (pcdif (- pc2 pc1))
	   (octdif (* ets (- octave2 octave1)))
	  )
        (if round? (round (+ pcdif octdif))
	           (+ pcdif octdif))
    )  
 )  
   

; simple transpose pitch
(defun tp (p n)
  (+ p n))

; transpose pitch-class   Tn
(defun tpc (pc pcint)
   (mod (+ pc pcint) 12))

; pc TnI
(defun ti (pc n)
  (mod (- n pc) 12))

; pc TnM5
(defun tm5 (pc n)
   (mod (+ n (* pc 5)) 12))

; pc TnM7
(defun tm7 (pc n)
   (mod (+ n (* pc 7)) 12))
   


; midi basics -----------------------

; translate pitch
(defconstant midi-base 4.00) 

; rounds to integral MIDI pitch
; from 8vepc in any ets
(defun 8vepc-to-midi (pitch &key (ets 12))
 (let ((pitch (xpitch pitch ets 12)))
   (round (+ (pc pitch) (* 12 (- (octp pitch) midi-base))))))
  
; converts from MIDI pitch to 8vepc in any ets
(defun midi-to-8vepc (midipitch &key (ets 12))
   (xpitch (+ midi-base (truncate midipitch 12) 
                (/ (rem midipitch 12) 100))
	    12 ets))

		
; translate time
(defun note-on (note) (car (getv note 'start)))

(defun note-off (note) 
   (+ (note-on note) (car (getv note 'dur))))
   

 
;;------------------------------------------------------------
;; microtonal utilities
;;------------------------------------------------------------


;; converts 8ve.pc from  ets1 to ets2  
(defun xpitch (pitch ets1 ets2)
	(let* ((octave (truncate pitch))
         	 (pc (coerce (* 100. (- pitch octave)) 'double-float))
		 (pc12 (* pc (/ ets2 ets1)))
		 )
		(+ octave (/ pc12 100.))))


; translates 8.pc from any ets into ets12 notation
; eg given an 8ve.pc in some arbitrary ets, express it in ets12
(defun mpitch (pitch &optional (vets 12.))
	(let* ((octave (truncate pitch))
         	 (pc (coerce (* 100. (- pitch octave)) 'double-float))
		 (pc12 (* pc (/ 12. vets)))
		 )
		(+ octave (/ pc12 100.))))
	
; translates 8.pc from ets12 notation into any ets (inverse of mpitch)
; eg given an 8ve.pc in ets12 notation, 
; express it in some arbitrary ets 8ve.pc notation
; useful for eg finding what notation in ets31 equals 8.04 in ets12 
; by (invmpitch 8.04 31) --> 8.103333,   
; so in ets31 10.3333 ets equal 4 ets in ets12
(defun invmpitch (pitch &optional (vets 12.))
	(let* ((octave (truncate pitch))
		 (pc  (coerce (* 100. (- pitch octave)) 'double-float))
		 (pcets (* pc (/  vets 12.)))
		 )
		(+ octave (/ pcets 100.))))



	
;; 8.ve.pc notation to Herz
(defun pitch-cps (pitch &key (ets 12) (octave-base 2))
  (let* ((octave (truncate pitch))
       	 (pc (* 100. (- pitch octave)))
	 (adjust 1.021973963705387d0)
	 )
    (* adjust (expt octave-base
		    (+ octave (/ pc ets)))))) 


;; different name for pitch-cps
(defun cpspch (pitch &key (ets 12) (octave-base 2))
	(pitch-cps pitch :ets ets :octave-base octave-base))
	
	
; difference in cents (hundredths of a ets12 semitone)
; eg (dcents (mpitch 8.10 31) 8.04)) gives cents between
; 8.10 in ets31 and 8.04 in ets12	
(defun dcents (pitch1 pitch2)		
; NB this works only for intervals within  an octave
	(* 10000. (- pitch1 pitch2)))	

	

; TRANSPOSE utility to transpose 8ve.pc notation by an interval
; with pitch in 8ve.pc notation (e.g. 8.03, e-flat above middle C),
; interval pitlev in semitones.
(defun transpose (pitch pitlev &key (ets 12))
   (let* ( (octave (truncate pitch))    
           (pc (* 100. (- pitch octave)))  ; number of pcs
           (pc (/ (round (* 1000.0 pc)) 1000.0))  ; round off computing error
	   (raw (+ pc pitlev))        ; raw addition
           (pcoctadd (truncate (/ raw ets)))            ; oct increment
           (newpc (- raw (* ets pcoctadd))) ; pc increment
	   (newoct (+ octave pcoctadd))
          )
       (cond ((< newpc 0) (setq newpc (+ newpc ets))
                          (setq newoct (- newoct 1.))))
       (cond ((< newoct 0.) "error - octave less than zero")
              ((+ newoct (/ newpc 100.))))
    )
 ) 

(defun ratio-to-cents (ratio)
	(coerce (* 1200. (/  (log ratio) (log 2)))
		'double-float))	
		
(defun cents-to-ratio (cents)
	(rationalize (exp 
		(/ (* cents (log 2)) 
		    1200) )))
		    
(defun ycents-to-ratio (cents)
	(rationalize (expt 2 (/ cents 1200))))

	;; these functions are not entirely accurate
	;; and neither pair really inverts
;; -----------------------------------------------------

;; assoc table with cents and ratios for Just intervals	
;; uses more accurate cents from function ratio-to-cents
(defconstant Just-assoc
	'((C 0 1 1) 
	(D 203.909988403203d0 9 8) 
	(Eb 315.64129638671875d0 6 5) 
	(E 386.3136901855469d0 5 4) 
	(F 498.0450134277344d0 4 3) 
	(F# 590.2236938476562d0 45 32) 
	(G 701.9549560546875d0 3 2) 
	(Ab 813.686279296875d0 8 5) 
	(A 884.3587036132812d0 5 3)
	(Bb 968.825927734375d0 7 4)
	(CC 1000.0 2 1))
 )


; eg (get-jcents 'd) --> 204
(defun get-Jcents (Just)
	(cadr (assoc Just Just-assoc)))

(defun get-jratio (Just)
	(let* ((nums (cddr (assoc Just Just-assoc)))	
		) 
			(/  (car nums) (cadr nums))))

(defun get-cents (pitch)  ; assumes 8ve.pc, returns cents above C
    (* 10000.0 (- pitch (float (truncate pitch)))))
    
; to compare any pitch in 8ve.pc with Just pitch (based on C)	
(defun jcompare (Jpitch pitch2)	
; ets12 notation assumed for pitch2
	(- (get-jcents Jpitch) (get-cents pitch2)))
	
; <cl> (jcompare 'a (p19 6.14))
;
;    0.14902 ...		
;  So, 14 ets19 steps are only .149 of a cent 
;  higher than a Just major 6th

; compares all notes in an ets with all 
; Just intervals in the Just-assoc list, 
; returns list of lists of differences in cents
; old versions
;(defun compare-ets (vets)
;	(do ((pc 1 (+ pc 1)) 
;		(result nil (cons (compare-ets-aux vets pc nil) 		
;		result)))
;		((= pc vets)  result)
;	)
; )
						
;(defun compare-ets-aux (vets pc result)
;	(do ((jlist Just-assoc (cdr jlist))
;	        (result nil 
;			(cons (jcompare (caar jlist) 
;				(mpitch (/  pc 100.0) vets)) 
;					result)))
;		((not jlist) result)
;	)
; )

; new versions
(defun compare-ets (vets)
	(do ((pc 1 (+ pc 1)) 
		(result nil (cons (compare-ets-aux vets pc) 		
		result)))
		((= pc vets)  result)
	)
 )
						
(defun compare-ets-aux (vets pc)
	(do ((jlist Just-assoc (cdr jlist))
	        (result nil 
			(cons (jcompare (caar jlist) 
				(mpitch (/  pc 100.0) vets)) 
					result)))
		((not jlist) result)
	)
 )



(defun abslist (alist) (mapcar 'abs alist)) 

;; nb all lists are in reverse order due to CONS 
(defun closest-cent (interval vets)
 	(apply 'min (abslist (nth (- vets interval 1) (compare-ets vets)))))
	
(defun closest-cents (vets)
	(do ((pc 1 (+ pc 1))
		(result nil 
			(cons (closest-cent pc vets) result)))
	 	((= pc vets) result)))
	
;; e.g. to generate a list of the differences in cents between
;; each interval of ets12 from 1 to 11 and the nearest match
;; from Just intonation,
;; (closest-cents 12)
;; This can be useful for comparing various ets systems
;; as to how closely they embed Just intonation.


;; takes flat list, returns list of dotted pairs numbering flat list
(defun number-list (alist &optional (start 1))
	(do* ((n start (+  n  1))
		 (xlist alist (cdr xlist))
		 (result (cons (cons n (car xlist)) nil)
			(cons (cons n (car xlist)) result))
		)
		((not (cdr xlist)) (reverse result))
	)
)


(defun least (alist) 
	(apply #'min (mapcar #'abs alist)))	
			
;; compare only the smallest 8 (number) 
;; differences eg (2 3 4 5 7 8 9 10) in one ets
;; simply adds up the absolute value differences
(defun measure (alist &optional (number 8))
	(do* ((n 1 (+ n 1))
	      (xlist (sort (abslist alist) #'<=)
			(cdr xlist))
	      (result (car xlist) (+ result (car xlist))) 
              )
             ( (or (not xlist) (= n number)) result)))
		
;; n.b. the average is a bad measure! (not used here)
;; Could use sqrt of sum of squares


;; automate : creates a list of cumulative sums
;; for all segments of sorted differences
;; eg nth element is sum of elements up to the nth element
;; of input list
(defun measures (alist)
	(do* ((end (length alist))
		(n 1 (+ 1 n))
		(result 
			(cons (measure alist n) nil)
			(cons (measure alist n) result))
		)
		((= n end) (reverse result))))
		
;; e.g. (measures (closest-cents 7)) gives a list
;; of all measures including from 1 to 7 smallest intervals 			    

(defun generate-ets-lists 
	(&optional (lower-bound 5)
			   (upper-bound 100))			   
	(do* ((n lower-bound (+ n 1))
		 (result (cons (measures (closest-cents n)) nil)
		 	    (cons (measures (closest-cents n))
			     		result))
		)
		((= n upper-bound) (reverse result))))
		
(defun print-ets-lists (filename &optional
					(lower-bound 5)
				   (upper-bound 100))
   (with-open-file
                   (ofile filename :direction :output)
                   (print  (generate-ets-lists
		   		lower-bound
				upper-bound) ofile)
    ) 
 )
 

;; pick out the measureth item in the systemth value list
;; in a list of lists such as *ets*
(defun pick-ets (system measure &optional (ets-list *ets*))
       (nth (- measure  1) (nth (- system 5) ets-list )))
;; nb *ets* is a constant storing (print-ets-lists)
;; just edit file to read (setq *ets* ' ... ) and load
      
(defun pick-8 ()
      (do* ((n  5 (+ n 1))
      	       (result (cons (pick-ets n 8) nil)
	      		  (cons (pick-ets n 8) result))
	      )
	      ((= n 100) (reverse result)))) 
	     
	     
;; find ets from 5 to 100 with best fit for inclusive-of-8 intervals
;;   nb cdddr since first 4 entries are nil, for ets5,6,7,8
;; pick best fit
(defun best-fit ()
	(rassoc (apply 'min (cddddr (pick-8))) 
		(number-list (pick-8) 5))
 )
;; answer is (53 . 7.3129712949336465d0) so investigate ets 53


(defun cycle-of  (int vets)
	(cycle-of-aux int vets 0 '(0)))
	
(defun cycle-of-aux (int vets n result) 
	(let ((n (+ 1 n)))
	(if (>=  n vets) (reverse result) 
		(cycle-of-aux 
			  int
			  vets  
			   n
			  (cons (mod (* n  int)  vets) result)))))

(defun diatonicp (arg &key (int 31) (sys 53) (half 27) (r 1))
	(subsetp arg
		(butlast (rotate (cycle-of int sys) r)
	       			(- sys half))	
	))
	
(defun alldiatonicp (arg &key
					(int 31) (sys 53) (half 27))
	(do* ((n 0 (+ n 1))
		 (dia? (diatonicp arg :int int :sys sys :half half :r n)
			(diatonicp arg :int int :sys sys :half half :r n))				 
		  (result nil
		  	     (if dia? (cons n result) result))
		  )
	     ((>= n sys) (pprint (reverse result)))
	     )
)

;; check for all interval cycles
(defun alldiatonic-allint-p (arg &key
					(sys 53) (half 27))
	(do* ((n 1 (+ n 1))
		 (dia? (alldiatonicp arg :int n :sys sys :half half)
			(alldiatonicp arg :int n :sys sys :half half))				 
		  (result nil
		  	     (if dia? (cons n result) result))
		  )
	     ((>= n sys) (pprint (reverse result)))
	     )
)
;;-------------------------------------------------------------
;; end microtonal utilities
;;---------------------------------------------------------------

; -----------some row utilities------------------------

(defun op-on-row (row op arg2)
   (mapcar #'(lambda (arg1) (funcall op arg1 arg2)) row))

(defun tprow (row n)
   (op-on-row row 'tp n))

(defun tpcrow (row n)
   (op-on-row row 'tpc n))

(defun tirow (row n)
   (op-on-row row 'ti n))

(defun tm5row (row n)
   (op-on-row row 'tm5 n))

(defun tm7row (row n)
   (op-on-row row 'tm7 n))

(defun transpose-row (row int)
  (op-on-row row #'transpose int))


;-----------------------------------------------------------
; utilities for lists of pcs, pitches, tps, tpcs 
;-----------------------------------------------------------


; ROTATE returns row = list rotated n to the right (adds n to order numbers)
(defun rotate1 (arow)
   (labels (( rot1aux (arow result)
      (cond ((not (cadr arow)) result)
            (t (rot1aux (cdr arow)
                       (append result (list (car arow))))))))
   (let ((lel (car (last arow))))
     (cons lel (rot1aux arow nil))
   )
 ))

(defun rotate (arow n)
   (labels (( rotaux (arow n counter)
      (cond ((< (abs (- counter n)) .1) arow)
            (t (rotaux (rotate1 arow) n (+ 1 counter))))))
   (rotaux arow n 0)))



(defun nextel (arow)
   (if arow (or (cadr arow) 12)
           12))

(defun nextelwrap (arow init)
  (if arow (or (cadr arow) init) init))

; returns a list of the first-order intervals (wrapped)
; of a list of 8ve.pc pitches
(defun pitchints-from-pitches (alist &key (round? nil))
  (labels ((intaux1 (alist init prev el result)
           (cond ((not alist) result)
            (t (intaux1 (cdr alist)
			init
                 (car (cdr alist))
                 (nextelwrap (cdr alist) init)
                 (append result (list (pitchint prev el :round? round?)))))))
	   )
   (let ((init (car alist)))
     (intaux1 alist init init (nextel alist) nil))
  )
)


(defun pitches-from-pitchints (start alist &key (ets 12) (round? nil))
   (labels ((intaux2 (alist el result)
             (cond ((not alist) result)
                (t (intaux2 (cdr alist)  
                       (car (cdr alist)) 
                       (append result 
		          (list 
			    (if round? (/ (round (* 100.0 
			          (transpose (car (last result)) 
				              el :ets ets))) 100.0)  
			          (transpose (car (last result)) el  :ets ets))
			    )
	               ))
		 )))
            )
   (intaux2 alist (car alist) (list start))
   )
 )

; old version
;(defun pitches-from-pitchints (start alist &key (ets 12) (round? nil))
;   (labels ((intaux2 (alist el result)
;             (cond ((not alist) result)
;                (t (intaux2 (cdr alist)  
;                       (car (cdr alist)) 
;                       (append result 
;		          (list 
;			    (transpose (car (last result)) el  :ets ets))
;	               ))
;		 )))
;            )
;   (intaux2 alist (car alist) (list start))
;   )
; )
 
 
; returns a list of the 12 first-order intervals of a row of mod12 elements
(defun pcints-from-els (arow)
   (labels (( intaux1 (arow init prev el result)
      (cond ((not arow) result)
            (t (intaux1 (cdr arow)
			init
                 (car (cdr arow))
                 (nextelwrap (cdr arow) init)
                 (append result (list (pcint prev el))))))))
   (let ((init (car arow)))
     (intaux1 arow init (car arow) (nextel arow) nil))
 ))


; pcels-from-ints takes an initial mod12 pc
; and a list of intervals and returns a list of mod12 pcs
; -- converse of ints-from-els
(defun pcels-from-ints (start arow)
   (labels (( intaux2 (arow el result)
      (cond ((not arow) result)
            (t (intaux2 (cdr arow)
                 (car (cdr arow))
                 (append result (list (tpc el (car (last result))))))))))
   (intaux2 arow (car arow) (list start))
 )
)


; modints-from-els takes a list and a modulus n and
; returns a list of the first-order intervals modn of the list 
(defun modints-from-els (arow &optional (modn 12))
   (labels (( intaux1 (arow init prev el result)
      (cond ((not arow) result)
            (t (intaux1 (cdr arow)
			init
                 (car (cdr arow))
                 (nextelwrap (cdr arow) init)
                 (append result (list (mod (- el prev) modn))))))))
   (let ((init (car arow)))
     (intaux1 arow init (car arow) (nextelwrap arow init) nil))
 ))


; models-from-ints takes an initial modn number, list, and modulus n
; and a list of intervals and returns a list of modn elements
; -- converse of ints-from-els
(defun models-from-ints (start arow modn)
   (labels (( intaux2 (arow el result)
      (cond ((not arow) result)
            (t (intaux2 (cdr arow)
                 (car (cdr arow))
                 (append result 
			 (list (mod (+ el (car (last result))) modn))))))))
   (intaux2 arow (car arow) (list start))
 ))


; returns a list of the first-order intervals of a list (not mod12)
(defun ints-from-els (arow)
   (labels ((intaux1 (arow init prev el result)
      (cond ((not arow) result)
            (t (intaux1 (cdr arow)
			init
                 (car (cdr arow))
                 (nextelwrap (cdr arow) init)
                 (append result (list (- el prev))))))))
   (let ((init (car arow)))
     (intaux1 arow init (car arow) (nextelwrap arow init) nil))
 ))


; els-from-ints takes an initial element start (not mod12)
; and a list of intervals and returns a list of elements
; -- converse of ints-from-els
(defun els-from-ints (arow &optional (start 0))
   (labels ((intaux2 (arow el result)
      (cond ((not arow) result)
            (t (intaux2 (cdr arow)
                 (car (cdr arow))
                 (append result (list (+ el (car (last result))))))))))
   (intaux2 arow (car arow) (list start))
 ))

(defun make-int-list (int n)
  (do* ((count 1 (+ 1 count))
	(result (list int) (cons int result)))
      ((= count (round n)) result)))


(defun granules (start dur cps)
  (els-from-ints (make-int-list (/ 1 cps) (round (* cps dur))) start))

(defun listplus (alist n)
  (op-on-row alist #'+ n))

; expands or contracts a list of elements by a factor
(defun expand-list (alist factor &optional (start 0))
	(els-from-ints (op-on-row  (ints-from-els alist) #'* factor) start
	 )
 )

; expands or contracts a list of intervals by a factor
(defun expand-ints (alist factor)
	(op-on-row alist #'* factor)
 )

;; NTH-APPLY applies a function n times recursively to a list of arguments
;; and returns the result of the nth application (very powerful)
(defun nth-apply (fn arglist n)
    (nth-apply-aux fn arglist n 1))

(defun nth-apply-aux (fn arglist n count)
    (cond (
	  (= count  n) (apply fn arglist))
	  ((> count n) "error -- zero applications")
	  (t (apply fn (list (nth-apply-aux fn arglist n (+ 1 count)))))
     )
 ) 

;; example, used to calculate version number n for Lisp Kernel
;; as nth square root of .9
(defun nth-sqrt (arg n)
   (nth-apply #'sqrt (list arg) n)) 




;; end pc and list utilites -------------------------------------------


;; --------------------- SETUP UTILITES -----------------------------
;; ------------------------------------------------------------------
;;                   setup utilities for composing
;; ------------------------------------------------------------------

; Set current piece to piece-name -- all output will go under this piece-name
; until it is reset. For use in conjunction with SAVE-NOTE (see below).
(defun piece (name)
   (assign-global 'current-piece name)
   (car (get-global 'current-piece)))

; Erase all notes of a piece
(defun clear-notes (&optional (name (car (get-global 'current-piece))))
   (assign-piece nil name))

;; clear current piece -- short-hand
(defun clr () (clear-notes (car (get-global 'current-piece))))

; pretty-print notes in a piece to screen
(defun show (&optional name)
   (if (not name) (pprint (get-piece (car (get-global 'current-piece))))
                  (pprint (get-piece name))))

; shows notes in a piece to screen, but only parameters in template are seen
; order of notes is order of generation
(defun see (&optional piece-name template)
   (do* ((piece-name (or piece-name (car (get-global 'current-piece))))
         (piece (get-piece piece-name) (cdr piece))
         (note (car piece) (car piece))
         (template (or template '(start dur pitch)))
	          (result (list (view-template note template))
                 (append result 
                             (list (view-template note 
                                                  template))))
         )
        ((not (cdr piece)) (pprint result))))


;---------------------
; to display notes in order of start times use ps

(defun sort-by-starts (alist)
   (sort alist #'<= :key #'(lambda (x) (car (getv x 'start)))))  

(defun se (&optional template)
   (do* (
         (piece (get-piece 'mc) (cdr piece))
         (note (car piece) (car piece))
         (template (or template '(start dur pitch)))
	          (result (list (view-template note template))
                    (append result 
                             (list (view-template note 
                                                  template))))
         )
        ((not (cdr piece))  result))) 
	
(defun sortse (&optional (template '(start dur pitch)))
   (sort-by-starts (se template))) 
   
(defun ps () (pprint (sortse)))	

;-----------------------

;; generic model of a function that initializes a new note
;; using the plist of the atom 'note as a scratch-pad
(defun create-note ()    ; clears 'note plist 
   (putpl 'note ())
   (getpl 'note)   ;; returns plist of 'note
   )    


; One version of a function that saves a note to the current piece.
; All such functions wil use the basic PUT-PIECE function (q.v.).
; SAVE-NOTE assumes the note-structure has been created as the property list
; the atom 'note. It always saves the note to the name of the
; current piece, which is set by the function (PIECE <name>)
(defun save-note ()
   (put-piece (getpl 'note) 
              (car (get-global 'current-piece)))
 )


;; assignment macro to be used inside defun of some note-producing function
(defmacro -> (par value)
   `(assign 'note ',par ,value)) 

; macro val is for retrieving values of parameters in a note definition
(defmacro val (par)
   `(car (getval 'note ',par)))


;  ------  end of SETUP UTILITIES -------------------------------



;; -------------------------SETUP-----------------------------------------

;;----------------------------------------------------------------------
;; file mcp.cl last updated 7/94
;; setup for mc.orc piece 'mc -- csound orchestra with microtonal capability
;; for sound mixing, fm, additive synthesis and graphical composition.
;;------------------------------------------------------------------------

; sets up for mc.orc instruments 1, 2, 3, 4 for a piece named 'mc 

;; To use these microtonal/graphic instruments and orchestra, 
;; you must first execute the following two commands 
;; to make the current piece in Lisp one called "mc".
;; This defines current piece to be 'mc -- 
;; important since notes are saved to this piece name, and other
;; values such as formats for parameters are looked up 
;; under the name of the current piece.
(piece 'mc)       ; defines current-piece to be 'mc
(clear-notes 'mc) ; clears 'mc database
;; (get-global 'current-piece) will return the name of the current piece.
;; function (clr) simply erases the current piece.
;; It all assumes there is a file mc.orc in your home directory
;; containing the csound orchestra for these instruments.
  
;; set global sampling rate in Lisp Kernel global variable
(assign-global 'sr 22050.0)
;; can retrieve by (car (get-global 'sr))

;; define a string for function definitions in csound orchestra 
;; score file header -- data for orchestra mc.orc
(defparameter cs-header "
; mc.sco
f 1 0 16385 10 1 0
f 2 0 2049 5 .001 2048 1
f 3 0 8193 7 0 8192 1
f 4 0 2049 5 1 2048 .001
f 5 0 2049 7 1 2048 0
f 6 0 8193 9 .25 1 0 ; quartersine
f 7 0 2049 5 1 2044 1 4 .0001     ; env for consonants
f 8 0 2049 5 .0001 24 1 2000 1 24 .0001   ; env for vowels
f 10 0 8193 9 .5 1 0  ; halfsine
f98 0 8192 7 0 4096 1 4096 0   ; linear halfsine (^)
f99 0 8192 7 0 2048 1 4096 -1 2048 0" ; linear sine (triangle)
)

; one global variable called overallgain is
; used for  adjusting maximum amplitude of result to 
; 32768 = 2**(16-1)
; for 16-bit DACs.
;; initialize overallgain at 1.
(defparameter overallgain 1.0)

;; to adjust amp up or down to maximum amp, for
;; best signal to noise ratio, take the larger of the
;; two "overall amps" channel maxima from the csound printout
;; as newmax, then (adjust-amp newmax)
;; NB most times it is good to do this by hand to avoid confusion,
;; rather than using this function, but it does tell you how.
(defun adjust-amp (newmax)
   (defparameter overallgain (* overallgain (/ 32768 newmax)))
   overallgain)
;; returns new value for inspection


;; define mods parameter. This is an LK environment 
;; which is passed as a parameter to the note-making
;; functions at each level. It enables global changes 
;; with local shadowing in a functional style,
;; without using global variables.
(defparameter mods (mass nil 'insnos 0 'starts 0.0 'durfac 1.0 'amplev 1 
	   'accent 1  'grampto 1 'gain 1
	   'riselev 0 'decaylev 0 'nfenvlev 0
	   'iatsslev 0 'iatdeclev 0 'ixmodlev 0
	   'fmi1lev 0 'fmi2lev 0 'ratiolev 0 'ratio2lev 0 'ratiofnlev 0
	   'ratiocpsfactor 1 'inddurlev 0 'devfnlev 0
	   'glissintlev 0 'glissfnlev 0 'glissdurlev 0
	   'crescfactorlev 0 'crescdurlev 0 'crescfnlev 0
	   'pitlev 0 'stleftlev 0 'stcpslev 0 'fmstcpslev 0 'stpchlev 0
	   'rvtlev 0 'pctrvblev 0 'soundinlev 0 'skptimelev 0
           'ets 53 'jitter 0 'seed .5))


 
;; pairs instrument numbers with instrument names (necessary for csound, cmix, Music4p)
(defun mc-orch (x) 
  (case x
    (1 'mix)
    (2 'mixlx)
    (3 'fm)
    (4 'addin)
  )
)

;; tell the kernel that mc-orch is to be used for piece mc
(assign-orch #'mc-orch 'mc)

;; 
(defun create-c ()    ; clears 'note plist 
   (putpl 'note ())
   t)    

; for mc.orc insno 1
(defun mix (start dur amp soundin skptime &key (mods mods))
  ;; insno 1: a very economical mixer, stereo in and out with amp control
   (create-c)
      (-> insno 1)
      (-> start (+ (* start (car (getv mods 'durfac)))
                   (car (getv mods 'starts))))
;      (-> dur (* dur (car (getv mods 'durfac)))) 
      (-> dur dur)	;; leave dur constant since sound is mixed from a source
      (-> amp (* amp (car (getv mods 'amplev))))
      (-> amp (* (val amp) (car (getv mods 'gain))))
      (-> amp (* (val amp) overallgain))  ; amp adjustment for soundfiles
      (-> soundin (+ soundin (car (getv mods 'soundinlev))))
      (-> skptime (+ skptime (car (getv mods 'skptimelev))))
   (save-note)		;; appends new note to LK database under name 'piece
 )

;; an alternate paradigm for creating note-structures appropriate for
;; a given instrument, and adding them to the list under the current
;; piece-name -- mix2 does exacly the same thing as mix, but in a 
;; more functional style of programming (no assigments).
;; to use mix2, you must rename it mix so that the orch and
;; format statements for mix will work.
(defun mix2 (start dur amp soundin skptime &key (mods mods))
   (put-piece (mass nil 'insno 1
			'start (+ (* start (car (getv mods 'durfac)))
                   		  (car (getv mods 'starts)))
			'dur dur
			'amp (* amp (car (getv mods 'amplev))
				    (car (getv mods 'gain))
				     overallgain)
			'soundin (+ soundin (car (getv mods 'soundinlev)))
			'skptime (+ skptime (car (getv mods 'skptimelev)))
               )
              (car (get-global 'current-piece))
     )
 )
 

;;  for mc.orc insno 2  (assumes nfenv is 8 for oscil env)
;;  a luxury mixing instrument
(defun mixlx (start dur amp soundin skptime
           &key (mods mods) (stleft 1) (stcps 0)
		(rvt 0) (pctrvb 0)
		(nfenv 8))
  ;; insno 2:
  ;; mixer with stereo in &keys stleft, stcps, rvt, pctrvb, nfenv
   (create-c)
      (-> insno 2)
      (-> start (+ (* start (car (getv mods 'durfac)))
                   (car (getv mods 'starts))))
;      (-> dur (* dur (car (getv mods 'durfac))))
      (-> dur dur)
      (-> amp (* amp (car (getv mods 'amplev)))) 
      (-> amp (* (val amp) (car (getv mods 'gain))))
      (-> amp (* (val amp) overallgain))  ; amp adjustment for soundfiles
      (-> soundin (+ soundin (car (getv mods 'soundinlev))))
      (-> skptime (+ skptime (car (getv mods 'skptimelev))))
      (-> stleft (+  stleft (car (getv mods 'stleftlev))))
      (-> stcps (+ stcps (car (getv mods 'stcpslev))))
      (-> rvt (+ rvt (car (getv mods 'rvtlev))))
      (-> pctrvb (+  pctrvb (car (getv mods 'pctrvblev))))
      (-> nfenv nfenv)
   (save-note)
 )



; a luxury FM instrument (insno 3 in class.orc)
; fmlx instrument pfields:
; p1 insno p2 start p3 dur p4 amp p5 8ve.pc
; p6 ratio m/c p7 fmi1 p8 fmi2 p9 devfunc [1]
; p10=rise p11=decay p12=nf for env [2] p13=iatss p14=iatdec p15=ixmod
; p16 ratio2 [ratio] p17 ratiofn [5] p18 ratiocps
; p19 dur for index sweep [dur]
; p20 gliss interval in semitones p21 dur for gliss [dur] p22 glissfn [1]
; p23 cresc factor p24 cresc dur [dur] p25 crescfn [3]
; p26 stereo initial portion in left channel [0] p27 stereo cps [.5]
; p27 pctrvb percent of sginal apssed through reverb
; p28 rvt reverb time in seconds
; p29 fmstcps cps for stereopan for fm portion
; p30 herz, calculated from pitch
; p31 ets specifies number of semitones per octave, taken from MODS
(defun fm (start dur amp pitch
           &key (mods mods) (fmi1 1) (fmi2 0) (devfn 5)
	   (rise .01) (decay .01) (nfenv 3)(iatss 1) (iatdec .01) (ixmod 0)
	   (ratio 1)(ratio2 0) (ratiofn 5) (ratiocps 0) (inddur 0)
	   (glissint 0) (glissdur 0) (glissfn 1)
	   (crescfactor 0) (crescdur 0) (crescfn 3)
	   (stleft .5) (stcps 0) (fmstcps 0)
	   (rvt 0) (pctrvb 0))
  ;; insno 3:
  ;; fmlx instrument with all bells and whistles but without post-filtering
   (create-c)
      (-> insno 3)
      (-> start (+ (* start (car (getv mods 'durfac)))
                   (car (getv mods 'starts))))
      (-> dur (* dur (car (getv mods 'durfac))))
      (-> amp (* amp (car (getv mods 'amplev))))
      (-> amp (* (val amp) (car (getv mods 'gain))))
      (-> amp (* (val amp) overallgain))  ; amp adjustment for soundfiles
      (-> ets (car (getv mods 'ets)))
      (-> pitch (transpose pitch (car (getv mods 'pitlev))  
      		:ets (car (getv mods 'ets))))
      (-> herz (pitch-cps (val pitch) :ets (car (getv mods 'ets)) ))
      (-> rise (+ rise (car (getv mods 'riselev))))
      (-> decay (+ decay (car (getv mods 'decaylev))))
      (-> nfenv (+ nfenv (car (getv mods 'nfenvlev))))
      (-> iatss (+ iatss (car (getv mods 'iatsslev))))
      (-> iatdec (+ iatdec (car (getv mods 'iatdeclev))))
      (-> ixmod (+ ixmod (car (getv mods 'ixmodlev))))
      (-> ratio (+ ratio (car (getv mods 'ratiolev))))
      (-> ratio2 (+ ratio2 (car (getv mods 'ratio2lev))))
      (-> fmi1 (+ fmi1 (car (getv mods 'fmi1lev))))
      (-> fmi2 (+ fmi2 (car (getv mods 'fmi2lev))))
      (-> devfn (+ devfn (car (getv mods 'devfnlev))))
      (-> ratiofn (+ ratiofn (car (getv mods 'ratiofnlev))))
      (-> inddur (+ inddur (car (getv mods 'inddurlev))))
      (-> ratiocps (* ratiocps (car (getv mods 'ratiocpsfactor))))
      (-> glissint (+ glissint (car (getv mods 'glissintlev))))
      (-> glissdur (+ glissdur (car (getv mods 'glissdurlev))))
      (-> glissfn (+ glissfn (car (getv mods 'glissfnlev))))
      (-> crescfactor (+ crescfactor (car (getv mods 'crescfactorlev))))
      (-> crescdur (+ crescdur (car (getv mods 'crescdurlev))))
      (-> crescfn (+ crescfn (car (getv mods 'crescfnlev))))
      (-> stleft (+  stleft (car (getv mods 'stleftlev))))
      (-> stcps (+ stcps (car (getv mods 'stcpslev))))
      (-> fmstcps (+ fmstcps (car (getv mods 'fmstcpslev))))
      (-> rvt (+ rvt (car (getv mods 'rvtlev))))
      (-> pctrvb (+  pctrvb (car (getv mods 'pctrvblev))))
   (save-note)
 )

 ;; insno 4: ADDIN -- a luxury oscil instrument for additive synthesis
 ; addin instrument pfields:
 ; p1 insno p2 start p3 dur p4 amp p5 Hz
; p6=rise p7=decay p8=nf for env [2] p9=iatss p10=iatdec p11=ixmod
; p12 gliss interval in semitones p13 dur for gliss [dur] p14 glissfn [1]
; p15 cresc factor p16 cresc dur [dur] p17 crescfn [3]
; p18 stereo initial portion in left channel [0] p19 stereo cps [0]
; p20 rvt p21 pctrvb p22 ets from mods  p23 and p24 stlimits [(0 1)]
; p25 random jitter magnitude, from mods   p26 seed for random, from mods
; ets from MODS
(defun addin (start dur amp pitch
           &key (mods mods) (herzin nil) 
 	   (rise .01) (decay .01) (nfenv 3)(iatss 1) (iatdec .01) (ixmod 0)
	   (glissint 0) (glissdur 0) (glissfn 1)
	   (crescfactor 0) (crescdur 0) (crescfn 3)
	   (stleft .5) (stcps 0) 
	   (rvt 0) (pctrvb 0) (stlimits '(0 1))
	   )
   (create-c)
      (-> insno 4)
      (-> start (+ (* start (car (getv mods 'durfac)))
                   (car (getv mods 'starts))))
      (-> dur (* dur (car (getv mods 'durfac))))
      (-> amp (* amp (car (getv mods 'amplev))))
      (-> amp (* (val amp) (car (getv mods 'gain))))
      (-> amp (* (val amp) overallgain))  ; amp adjustment for soundfiles
      (-> pitch (transpose pitch (car (getv mods 'pitlev))  
      		:ets (car (getv mods 'ets))))
      (-> herz (pitch-cps (val pitch) :ets (car (getv mods 'ets)) ))
      (if herzin (-> herz herzin)) ; supersedes pitch, no transpose
      (-> rise (+ rise (car (getv mods 'riselev))))
      (-> decay (+ decay (car (getv mods 'decaylev))))
      (-> nfenv (+ nfenv (car (getv mods 'nfenvlev))))
      (-> iatss (+ iatss (car (getv mods 'iatsslev))))
      (-> iatdec (+ iatdec (car (getv mods 'iatdeclev))))
      (-> ixmod (+ ixmod (car (getv mods 'ixmodlev))))
      (-> glissint (+ glissint (car (getv mods 'glissintlev))))
      (-> glissdur (+ glissdur (car (getv mods 'glissdurlev))))
      (-> glissfn (+ glissfn (car (getv mods 'glissfnlev))))
      (-> crescfactor (+ crescfactor (car (getv mods 'crescfactorlev))))
      (-> crescdur (+ crescdur (car (getv mods 'crescdurlev))))
      (-> crescfn (+ crescfn (car (getv mods 'crescfnlev))))
      (-> stleft (+  stleft (car (getv mods 'stleftlev))))
      (-> stcps (+ stcps (car (getv mods 'stcpslev))))
      (-> rvt (+ rvt (car (getv mods 'rvtlev))))
      (-> pctrvb (+  pctrvb (car (getv mods 'pctrvblev))))
      (-> ets (car (getv mods 'ets)))
      (-> stleftlimit  (car stlimits))
      (-> strightlimit (car (cdr stlimits)))
      (-> jitter (car (getv mods 'jitter)))
      (-> seed (car (getv mods 'seed)))
   (save-note)
 )

  
(assign-template 'mix '(insno start dur soundin skptime amp))

(assign-template 'mixlx '(insno start dur soundin skptime 
		       stleft stcps nfenv amp
		       pctrvb rvt))

(assign-template 'fm '(insno start dur amp pitch
		       ratio fmi1 fmi2 devfn
		       rise decay nfenv iatss iatdec ixmod
		       ratio2 ratiofn ratiocps inddur
		       glissint glissdur glissfn
		       crescfactor crescdur crescfn
		       stleft stcps pctrvb rvt fmstcps herz ets))
 
(assign-template 'addin '(insno start dur amp herz
                       rise decay nfenv iatss iatdec ixmod
  	               glissint glissdur glissfn
	    	       crescfactor crescdur crescfn
		       stleft stcps rvt pctrvb ets 
		       stleftlimit strightlimit jitter seed))
 
                     
;; set default formats for each instrument
;; to something reasonable in case you
;; add parameters that do not have explicit formats (see below)
(assign-default-format 'mix "~14,5f")
(assign-default-format 'mixlx "~14,5f")
(assign-default-format 'fm "~14,5f")
(assign-default-format 'addin "~14,5f")

;; assign explicit formats as desired for each parameter
;; for each instrument
(assign-parameter-formats 'mix
			  'insno "~2,0f"
			  'start "~10,4f"
			  'dur "~8,4f"
			  'soundin "~3,0f"
			  'skptime "~8,6f"
			  'amp "~18,6f")

(assign-parameter-formats 'mixlx
			  'insno "~2,0f"
			  'start "~11,5f"
			  'dur "~11,5f"
			  'soundin "~3,0f"
			  'skptime "~10,5f"
			  'stleft "~7,4f"
			  'amp "~18,6f"
			  'stpch "~6,4f"
			  'stcps "~8,2f"
			  'nfenv "~3,0f"
			  'pctrvb "~6,4f"
			  'rvt "~6,4f")

(assign-parameter-formats 'fm
			  'insno "~2,0f"
			  'start "~11,5f"
			  'dur "~11,5f"
			  'amp "~18,5f"
			  'pitch "~9,5f"
			  'herz "~10,4f"
			  'ratio "~8,4f"
			  'fmi1 "~6,4f"
			  'fmi2 "~6,4f"
			  'devfn "~4,0f"
			  'rise "~8,4f"
			  'decay "~8,4f"
			  'nfenv "~4,0f"
			  'iatss "~6,4f"
			  'iatdec "~7,5f"
			  'ixmod "~6,4f"
			  'ratio2 "~8,4f"
			  'ratiofn "~4,0f"
			  'ratiocps "~9,4f"
			  'inddur "~8,2f"
			  'glissint "~8,4f"
			  'gliss