utilities.lsp
 Version 1.01 02 Jun 2005, Removed several never-used functions.
 Version 1.00 31 October 2004
 Author Steven Jones

 Contact jones57@swbell.net include the word "nyquist" in subject line

 The contents of this file are released under the terms of the GNU General
 Public License. See the file LICENSE.txt

 General utility functions

function

 (tl)
 An alias for top-level

function

 (ann)
 An alias for (auotnorm-on)

function

 (anf)
 An alias for (autonorm-off)

macro

 (? obj)
 Combination of args and grindef
 Prints list of arguments to and lambda expression of obj

 obj   - closure

function

 (current-file file)
 Set *current-file* to file. The current file is used in conjunction with
 the rl function to quickly reload a file under development.

 file - string. 

function

 (errload file)
 Load lisp file with error check. If file can not be loaded an error is
 produced.

 file - string

function

 (rl)
 Reload the "current-file" 

function

 (load-list lst)
 Load list of lisp files.
 
 lst - List of strings

function

 (rla)
 Reload all files in *modules*. Typically files are appended to *modules* by
 the provide function

function

 (list-packages)
 List the files in *modules*

function

 (nice-load file)
 Load file without changing the current file
 
 file - string

function

 (is-loaded-p sym)
 Determine if package represented by symbol has been loaded. Specifically
 check to see if *modules* contains the symbol sym

 sym    - symbol.
 return - bool.

function

 (provide sym)
 Add symbol sym to *modules* list indicating a specific package has
 been loaded. Provide is used in conjunction with require

 sym - symbol. The package name

function

 (require sym [filelist])
 Conditionally load file(s) 
 
 sym      - symbol. A symbol representing package name. If a symbol by the
            same name is a member of *modules* no further action is taken.
            If *modules* does not contain sym an attempt is made to
            load one or more files. If any one of the loaded files calls
            provide with sym as an argument, then future calls to 
            (require sym) will be ignored, preventing redundant file
            loading.  If the optional filelist argument is not specified the
            filename is derived from the symbol name of sym. One consequent
            of using the symbol name is that filenames
            MUST NOT CONTAIN UPPER CASE CHARACTERS.

 filelist - symbol, string, list. If filelist is not specified the filename
            is derived from the symbol name of sym. If filelist is
            specified it may take one of three forms.

            filelist may be a symbol. In this case the symbol name is
            converted to a lower case string and used as the filename.

            filelist may also be a string. In the case of a string the
            value of filelist is used directly as the filename, mixed case 
            names are possible.

            filelist may be a list of strings. In this case ALL files in 
            filelist are loaded, mixed case names are allowed.

function

 (here [a [b [c ...]]])
 Debug aid used to trace execution. Prints the word "HERE" followed by its
 arguments

 a, b, c - any.

function

 (min-control-time)

 return - flonum, The minimum time, in seconds, resolvable at the current
          control sample rate

function

 (min-sample-time)

 return - flonum, The minimum time, in seconds, resolvable at the current
          audio sample rate

function

 (msound snd)
 Multi-channel version of sound

 snd    - sound or array of sounds
 return - sound or array of sounds

function

 (->vector obj [dim])
 Convert obj to vector. 

 obj    - any. If obj is a vector it is returned directly, the dim argument
          is ignored. If obj is any non-vector object, a vector of dimension
          dim is created and filled with dim copies of obj.

 dim    - integer. The number of elements of the resulting vector. 
          The dim value is ignored if obj is an vector to start with. 
          Default 2

 return - vector

function

 (->mono obj)
 Convert sound(s) to mono.
 
 obj    - sound, vector or list of sounds. If obj is a simple sound object it
          is returned directly. If obj is either a vector or list of sounds, 
          the sound elements are mixed to a single sound object.

 return - sound.

function

 (invert sig)
 Perform amplitude inversion of signal

 sig    - sound
 return - sound with the same sample rate as signal.

function

 (phase [n])
 Used to provide the phase argument to osc, fmosc etc.

 n      - any. If n is nil the result is 0.
          if n is any number, the returned value is that number
          if n is non-numeric and true (not nil) the result is a random 
          integer between 0 and 359

 return - flonum or integer

function

 (idfn arg)
 An identity function simply returns its argument.

 arg    - any.
 return - any.

function

 (vector->list vec)
 Convert vector to list

function

 (list->vector)
 Convert list to vector

function

 (zip  lst1 lst2)
 Create new list by taking alternate elements from source list
 (zip '(a b c) '(1 2 3)) --> (a 1 b 2 c 3)

 lst1   - list
 lst2   - list
 return - list. The length of the result is the same as the shortest
          argument list

function

 (butlast lst)
 (butlast '(a b c d)) --> (a b c)
 lst    - list
 return - list. Return all but the final list node of lst

function

 (group lst)
 Group elements of list into sub-list
 (group '(a b c d)) --> ((a b)(c d))
 
 lst    - list
 return - list

function

 (rotate lst [n [fn]])
 Apply function fn to final list element and rotate it to front of list

 lst    - list 
 n      - integer. Number of elements to rotate, default 1
 fn     - closure. The function applied to the rotated elements. The function
          should take a single element.
 return - list

function

 (-rotate lst [n [fn]])
 Same as rotate but in opposite direction.

function

 (flatten lst)
 Remove list sub-list
 (flatten '(a (b (c (d))))) --> (a b c d)
 
 lst    - list
 return - list

function

 (nflatten lst n)
 Same as flatten but only descend n levels
 (nflatten '(a (b (c (d (e))))) 2) --> (a b c (d (e)))

 lst    - list
 n      - integer
 return - list

function

 (flatten-sublist lst)
 (flatten-sublist '(a b (c)(d (e f)))) --> ((a)(b)(c)(d e f))

 lst    - list
 return - list

function

 (nest lst)
 Replace every element of a list by a list containing it.
 (nest '(a b c d)) --> ((a)(b)(c)(d))
 
 lst    - list
 return - list

function

 (locate lst obj [:test])
 Return least index of obj in list.

 lst    - list
 obj    - any. Object to test
 :test  - closure. The equality test, default #'eq
 return - integer. If obj is not an element of lst return nil

function

 (->list obj)
 Convert object to list

 obj    - any
 return - list. If obj is a list it is returned directly, otherwise embed obj
          in a list and return

function

 (copies [n [obj])
 Create list of n copies of obj

 n      - integer, default 1
 obj    - any
 return - list

function

 (sublist-extract lst n)
 Build list consisting of the nth element of each sublist of lst.
 (sublist-extract '((q w e)(a s d)(z x c)) 1) --> (w s x)
 
 lst    - list
 n      - integer
 return - list

function

 (eliminate-duplicates  lst [:test])
 Construct new list which contains only the unique elements of lst

 lst    - list
 :test  - closure, default #'eq
 return - list

function

 (get-keyword-value keysym arglist [default])
 Return value -after- keysym in the list. Typically used to parse keywords
 from argument list created by &rest

 (get-keyword-value '(a b c :ape 1 :bat 2) ':ape) --> 1

 keysym  - symbol
 arglist - list
 default - any. The default value if arglist does not contain keysym
 return  - any

function

 (require-keyword keysym arglist [message])
 Like get-keyword-symbol but produces a warning message
 if keysym is not a member of arglist

 keysym  - symbol. The key symbol 

 arg     - list. The list of keyword/value pairs arguments.

 message - string. Additional error message text
 
 return  - any.

function

 (every-odd lst)
 Generate new list consisting of only the odd numbered elements of argument
 list
 
 lst    - list.
 return - list.

function

 (every-even lst)
 Generate new list consisting of only the even numbered elements 
 of argument list

 lst    - list
 return - list

function

 (fifth lst)

 lst    - list
 return - any. The fifth element of lst

function

 (sixth lst)

 lst    - list
 return - any. The sixth element of lst

;; utilities.lsp
;; Version 1.01 02 Jun 2005, Removed several never-used functions.
;; Version 1.00 31 October 2004
;; Author Steven Jones
;;
;; Contact jones57@swbell.net include the word "nyquist" in subject line
;;
;; The contents of this file are released under the terms of the GNU General
;; Public License. See the file LICENSE.txt
;;
;; General utility functions
;;

;; ************************************************************************** 
;;		A few functions for convenient interactive use
;; ************************************************************************** 

;; @doc function tl
;; (tl)
;; An alias for top-level
;;

(setfn tl top-level)


;; @doc function ann
;; (ann)
;; An alias for (auotnorm-on)
;;

(setfn ann autonorm-on)


;;@doc function anf
;; (anf)
;; An alias for (autonorm-off)
;;

(setfn anf autonorm-off)


;; @doc macro ?
;; (? obj)
;; Combination of args and grindef
;; Prints list of arguments to and lambda expression of obj
;;
;; obj   - closure
;;

(defmacro ? (obj)
  `(progn (args ',obj)
	  (grindef ',obj)))


;; ************************************************************************** 
;;			     Lisp File Management
;; ************************************************************************** 

;; @doc function current-file
;; (current-file file)
;; Set *current-file* to file. The current file is used in conjunction with
;; the rl function to quickly reload a file under development.
;;
;; file - string. 
;;

(defun current-file (file)
  (setq *current-file* file))


(current-file "utilities")


;; @doc function errload
;; (errload file)
;; Load lisp file with error check. If file can not be loaded an error is
;; produced.
;;
;; file - string
;;

(defun errload (file)
  (gc-reset)
  (format t "~%")
  (if (not (load file))
      (error (format nil "Could not load file ~s~%" file))))


;; @doc function rl
;; (rl)
;; Reload the "current-file" 
;;

(defun rl ()
  (format t "~%reloading ~s~%" *current-file*)
  (errload *current-file*))


;; @doc function load-list
;; (load-list lst)
;; Load list of lisp files.
;; 
;; lst - List of strings
;;

(defun load-list (lst)
  (if lst
      (progn 
	(format t "loading ~s~%" (car lst))
	(errload (car lst))
	(load-list (cdr lst)))
    (format t "DONE~%")))


;; @doc function rla
;; (rla)
;; Reload all files in *modules*. Typically files are appended to *modules* by
;; the provide function
;;

(defun rla ()
  (dotimes (n (length *modules*))
    (let ((file (string-downcase (symbol-name (nth n (reverse *modules*))))))
      (errload file))))


;; @doc function list-packages
;; (list-packages)
;; List the files in *modules*
;;

(defun list-packages (&optional (lst *modules*))
  (if lst
      (progn 
	(format t "~A~%" (car lst))
	(list-packages (cdr lst)))))


;; @doc function nice-load
;; (nice-load file)
;; Load file without changing the current file
;; 
;; file - string
;; 

(defun nice-load (file)
  (let ((temp *current-file*)
	(rs nil))
    (setq rs (errload file))
    (setq *current-file* temp)
    rs))


;; @doc function is-loaded-p
;; (is-loaded-p sym)
;; Determine if package represented by symbol has been loaded. Specifically
;; check to see if *modules* contains the symbol sym
;;
;; sym    - symbol.
;; return - bool.
;;

(defun is-loaded-p (sym)
  (member sym *modules* :test #'eq))


;; @doc function provide
;; (provide sym)
;; Add symbol sym to *modules* list indicating a specific package has
;; been loaded. Provide is used in conjunction with require
;;
;; sym - symbol. The package name
;;

(defun provide (sym)
  (if (not (is-loaded-p sym))
       (setq *modules* (cons sym *modules*))))


;; @doc function require
;; (require sym [filelist])
;; Conditionally load file(s) 
;; 
;; sym      - symbol. A symbol representing package name. If a symbol by the
;;            same name is a member of *modules* no further action is taken.
;;            If *modules* does not contain sym an attempt is made to
;;            load one or more files. If any one of the loaded files calls
;;            provide with sym as an argument, then future calls to 
;;            (require sym) will be ignored, preventing redundant file
;;            loading.  If the optional filelist argument is not specified the
;;            filename is derived from the symbol name of sym. One consequent
;;            of using the symbol name is that filenames
;;            MUST NOT CONTAIN UPPER CASE CHARACTERS.
;;
;; filelist - symbol, string, list. If filelist is not specified the filename
;;            is derived from the symbol name of sym. If filelist is
;;            specified it may take one of three forms.
;;
;;            filelist may be a symbol. In this case the symbol name is
;;            converted to a lower case string and used as the filename.
;;
;;            filelist may also be a string. In the case of a string the
;;            value of filelist is used directly as the filename, mixed case 
;;            names are possible.
;;
;;            filelist may be a list of strings. In this case ALL files in 
;;            filelist are loaded, mixed case names are allowed.
;;

(defun require (sym &optional filelist)
  (if (not (member sym *modules*))
      (cond ((null filelist)
	     (errload (string-downcase (symbol-name sym))))
	    ((listp filelist)
	     (dotimes (n (length filelist))
	       (errload (nth n filelist))))
	    ((stringp filelist)
	     (errload filelist))
	    (t (errload (string-downcase (symbol-name filelist)))))))


;; @doc function here
;; (here [a [b [c ...]]])
;; Debug aid used to trace execution. Prints the word "HERE" followed by its
;; arguments
;;
;; a, b, c - any.
;;

(defun here (&rest args)
  (format t "HERE ")
  (do ((index 0 (+ index 1)))
      ((> index (- (length args) 1)))
    (format t "~s " (nth index args)))
  (format t "~%"))


;; ************************************************************************** 
;;		       Basic signal and sound functions
;; ************************************************************************** 

;; @doc function min-control-time
;; (min-control-time)
;;
;; return - flonum, The minimum time, in seconds, resolvable at the current
;;          control sample rate
;;

(defun min-control-time ()
  (/ (float *control-srate*)))


;; @doc function min-sample-time
;; (min-sample-time)
;;
;; return - flonum, The minimum time, in seconds, resolvable at the current
;;          audio sample rate
;;

(defun min-audio-time ()
  (/ (float *sound-srate*)))


;; @doc function msound
;; (msound snd)
;; Multi-channel version of sound
;;
;; snd    - sound or array of sounds
;; return - sound or array of sounds
;;

(defun msound (snd)
  (multichan-expand #'sound snd))


;; @doc function ->vector
;; (->vector obj [dim])
;; Convert obj to vector. 
;;
;; obj    - any. If obj is a vector it is returned directly, the dim argument
;;          is ignored. If obj is any non-vector object, a vector of dimension
;;          dim is created and filled with dim copies of obj.
;;
;; dim    - integer. The number of elements of the resulting vector. 
;;          The dim value is ignored if obj is an vector to start with. 
;;          Default 2
;;
;; return - vector
;;

(defun ->vector (obj &optional (dim 2))
  (if (arrayp obj)
      obj
    (let ((arr (make-array dim)))
      (dotimes (i dim)
	(setf (aref arr i) obj))
      arr)))


;; @doc function ->mono
;; (->mono obj)
;; Convert sound(s) to mono.
;; 
;; obj    - sound, vector or list of sounds. If obj is a simple sound object it
;;          is returned directly. If obj is either a vector or list of sounds, 
;;          the sound elements are mixed to a single sound object.
;;
;; return - sound.
;;

(defun ->mono (obj)
  (cond ((soundp obj) obj)
	((arrayp obj)
	 (simrep (i (length obj))(aref obj i)))
	((listp obj)
	 (simrep (i (length obj))(nth i obj)))
	(t (error (format nil "->mono bad argument type ~a" obj)))))


;; @doc function invert
;; (invert sig)
;; Perform amplitude inversion of signal
;;
;; sig    - sound
;; return - sound with the same sample rate as signal.
;;

(defun invert (sig)(scale -1 sig))


;; @doc function phase
;; (phase [n])
;; Used to provide the phase argument to osc, fmosc etc.
;;
;; n      - any. If n is nil the result is 0.
;;          if n is any number, the returned value is that number
;;          if n is non-numeric and true (not nil) the result is a random 
;;          integer between 0 and 359
;;
;; return - flonum or integer
;;

(defun phase (&optional n)
  (cond ((null n) 0)
	((numberp n) n)
	(t (random 360))))


;; @doc function idfn
;; (idfn arg)
;; An identity function simply returns its argument.
;;
;; arg    - any.
;; return - any.
;;

(defun idfn (arg) arg)


;; ************************************************************************** 
;;				List Functions
;; ************************************************************************** 

;; @doc function vector->list
;; (vector->list vec)
;; Convert vector to list
;;

(defun vector->list (vec)
  (do ((i 0 (+ i 1))(acc '()(cons (aref vec i) acc)))
      ((= i (length vec))(reverse acc))))


;; @doc function list->vector
;; (list->vector)
;; Convert list to vector
;;

(defun list->vector (lst)
  (do ((I 0 (+ i 1))(acc (make-array (length lst))))
      ((= i (length acc)) acc)
    (setf (aref acc i)(nth i lst))))


;; @doc function zip
;; (zip  lst1 lst2)
;; Create new list by taking alternate elements from source list
;; (zip '(a b c) '(1 2 3)) --> (a 1 b 2 c 3)
;;
;; lst1   - list
;; lst2   - list
;; return - list. The length of the result is the same as the shortest
;;          argument list
;;

(defun zip (lst1 lst2)
  (if (or (null lst1)(null lst2))
      nil
    (cons (car lst1)
	  (cons (car lst2)
		(zip (cdr lst1)(cdr lst2))))))


;; @doc function butlast
;; (butlast lst)
;; (butlast '(a b c d)) --> (a b c)
;; lst    - list
;; return - list. Return all but the final list node of lst
;;

(defun butlast (lst)
  (reverse (cdr (reverse lst))))


;; @doc function group
;; (group lst)
;; Group elements of list into sub-list
;; (group '(a b c d)) --> ((a b)(c d))
;; 
;; lst    - list
;; return - list
;;

(defun group (lst)
  (if lst
      (cons (list (car lst)(second lst))(group (cdr (cdr lst))))
    nil))


;; @doc function rotate
;; (rotate lst [n [fn]])
;; Apply function fn to final list element and rotate it to front of list
;;
;; lst    - list 
;; n      - integer. Number of elements to rotate, default 1
;; fn     - closure. The function applied to the rotated elements. The function
;;          should take a single element.
;; return - list
;;

(defun rotate (lst &optional (n 1)(fn #'idfn))
  (if (<= n 0)
      lst
    (rotate (cons (funcall fn (car (last lst)))(butlast lst))(- n 1) fn)))


;; @doc function -rotate
;; (-rotate lst [n [fn]])
;; Same as rotate but in opposite direction.
;;

(defun -rotate (lst &optional (n 1)(fn #'idfn))
  (if (<= n 0)
      lst
    (-rotate (reverse (cons (funcall fn (car lst))(reverse (cdr lst))))(- n 1) fn)))


;; @doc function flatten
;; (flatten lst)
;; Remove list sub-list
;; (flatten '(a (b (c (d))))) --> (a b c d)
;; 
;; lst    - list
;; return - list
;;

(defun flatten (lst)
   (cond ((null lst) nil)
	((atom lst)(list lst))
	(t (append (flatten (car lst))
		   (flatten (cdr lst))))))


;; @doc function nflatten 
;; (nflatten lst n)
;; Same as flatten but only descend n levels
;; (nflatten '(a (b (c (d (e))))) 2) --> (a b c (d (e)))
;;
;; lst    - list
;; n      - integer
;; return - list
;;

(defun nflatten (lst n)
  (cond ((null lst) nil)
	((atom lst)(list lst))
	(t (if (plusp n)
	       (append (nflatten (car lst) (- n 1))
		       (nflatten (cdr lst) n))
	     (cons (car lst)
		     (nflatten (cdr lst) n))))))


;; @doc function flatten-sublist 
;; (flatten-sublist lst)
;; (flatten-sublist '(a b (c)(d (e f)))) --> ((a)(b)(c)(d e f))
;;
;; lst    - list
;; return - list
;;

(defun flatten-sublist (lst)
  (if lst
      (cons (flatten (car lst))(flatten-sublist (cdr lst)))
    nil))


;; @doc function nest
;; (nest lst)
;; Replace every element of a list by a list containing it.
;; (nest '(a b c d)) --> ((a)(b)(c)(d))
;; 
;; lst    - list
;; return - list
;;

(defun nest (lst)
  (if (null lst)
      nil
    (cons (list (car lst))(nest (cdr lst)))))


;; @doc function locate
;; (locate lst obj [:test])
;; Return least index of obj in list.
;;
;; lst    - list
;; obj    - any. Object to test
;; :test  - closure. The equality test, default #'eq
;; return - integer. If obj is not an element of lst return nil
;;

(defun locate (lst obj &key (test #'eq))
  (let ((rs (member obj lst :test test)))
    (if (null rs)
	'NIL
      (- (length lst)(length rs)))))


;; @doc function ->list
;; (->list obj)
;; Convert object to list
;;
;; obj    - any
;; return - list. If obj is a list it is returned directly, otherwise embed obj
;;          in a list and return
;;

(defun ->list  (obj)
  (if (listp obj) obj (list obj)))


;; @doc function copies 
;; (copies [n [obj])
;; Create list of n copies of obj
;;
;; n      - integer, default 1
;; obj    - any
;; return - list
;;

(defun copies (&optional (n 1)(obj nil))
  (if (plusp n)
      (cons obj (copies (- n 1) obj))
    nil))


;; @doc function sublist-extract
;; (sublist-extract lst n)
;; Build list consisting of the nth element of each sublist of lst.
;; (sublist-extract '((q w e)(a s d)(z x c)) 1) --> (w s x)
;; 
;; lst    - list
;; n      - integer
;; return - list
;;

(defun sublist-extract (lst n)
  (if (null lst)
      nil
    (cons (nth n (car lst))(sublist-extract (cdr lst) n))))


;; @doc function eliminate-duplicates
;; (eliminate-duplicates  lst [:test])
;; Construct new list which contains only the unique elements of lst
;;
;; lst    - list
;; :test  - closure, default #'eq
;; return - list
;;

(defun eliminate-duplicates (lst &key (test #'eq))
  (let ((acc '()))
    (dolist (e lst)
      (if (not (member e acc :test test))
	  (setf acc (cons e acc))))
    (reverse acc)))


;; @doc function get-keyword-value
;; (get-keyword-value keysym arglist [default])
;; Return value -after- keysym in the list. Typically used to parse keywords
;; from argument list created by &rest
;;
;; (get-keyword-value '(a b c :ape 1 :bat 2) ':ape) --> 1
;;
;; keysym  - symbol
;; arglist - list
;; default - any. The default value if arglist does not contain keysym
;; return  - any
;;

(defun get-keyword-value (keysym arglist &optional default)
  (let ((sublist (member keysym arglist)))
    (if sublist (or (car (cdr sublist)) default)
      default)))


;; @doc function require-keyword
;; (require-keyword keysym arglist [message])
;; Like get-keyword-symbol but produces a warning message
;; if keysym is not a member of arglist
;;
;; keysym  - symbol. The key symbol 
;;
;; arg     - list. The list of keyword/value pairs arguments.
;;
;; message - string. Additional error message text
;; 
;; return  - any.
;;

(defun require-keyword (keysym arglist &optional (message ""))
  (let ((sublist (member keysym arglist)))
    (if sublist (car (cdr sublist))
      (warning "Required keyword missing" (symbol-name keysym) message))))


;; @doc function every-odd
;; (every-odd lst)
;; Generate new list consisting of only the odd numbered elements of argument
;; list
;; 
;; lst    - list.
;; return - list.
;;

(defun every-odd (lst)
  (if lst
      (cons (car lst)(every-odd (cdr (cdr lst))))
    nil))


;; @doc function every-even
;; (every-even lst)
;; Generate new list consisting of only the even numbered elements 
;; of argument list
;;
;; lst    - list
;; return - list
;;

(defun every-even (lst)
  (if (cdr lst)
      (cons (car (cdr lst))(every-even (cdr (cdr lst))))
    nil))


;; @doc function fifth
;; (fifth lst)
;;
;; lst    - list
;; return - any. The fifth element of lst
;;

(defun fifth (lst)
  (if lst (nth 4 lst) nil))


;; @doc function sixth
;; (sixth lst)
;;
;; lst    - list
;; return - any. The sixth element of lst
;;

(defun sixth (lst)
  (if lst (nth 5 lst) nil))


(provide 'utilities)