;;; **********************************************************************
;;; Copyright (C) 2003 Heinrich Taube (taube@uiuc.edu) 
;;; This program is free software; you can redistribute it and
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;; **********************************************************************

;;; generated by scheme->cltl from data.scm on 23-Mar-2005 12:21:16

(in-package :cm)

(defparameter interval-semitones-byte (byte 4 0))

(defparameter interval-octaves-byte (byte 4 4))

(defparameter interval-letters-byte (byte 3 8))

(defparameter interval-direction-byte (byte 1 11))

(defparameter interval-type-byte (byte 3 12))

(defparameter interval-class-byte (byte 1 15))

(defparameter interval-meta-byte (byte 4 16))

(defparameter interval-meta-flag 1)

(defparameter interval-down-flag 1)

(defparameter interval-up-flag 0)

(defparameter interval-perfect-flag 1)

(defparameter interval-majmin-flag 0)

(defparameter interval-data-mask 2047)

(defparameter interval-names #((doubly-diminished ddim dd)
                               (diminished dim d)
                               (minor min mi m)
                               (perfect perf p)
                               (major maj ma mj)
                               (augmented aug a)
                               (doubly-augmented aaug aa)))

(defmacro %interval-encoded? (n)
  `(= (ldb interval-meta-byte ,n) interval-meta-flag))

(defmacro %interval-class (n) `(ldb interval-class-byte ,n))

(defmacro %interval-type (n) `(ldb interval-type-byte ,n))

(defmacro %interval-direction (n) `(ldb interval-direction-byte ,n))

(defmacro %interval-sign (n)
  `(if (= (ldb interval-direction-byte ,n) interval-down-flag) -1 1))

(defmacro %interval-letters (n) `(ldb interval-letters-byte ,n))

(defmacro %interval-octaves (n) `(ldb interval-octaves-byte ,n))

(defmacro %interval-semitones (n) `(ldb interval-semitones-byte ,n))

(defun interval-quality-type (int)
  (if (%interval-encoded? int)
      (if (= (%interval-class int) interval-perfect-flag)
          'perfect
          'imperfect)
      nil))

(defun interval-quality (int)
  (if (%interval-encoded? int)
      (car (elt interval-names (%interval-type int)))
      nil))

(defun interval-letters (int)
  (if (%interval-encoded? int) (%interval-letters int) nil))

(defun interval-semitones (int &optional abs?)
  (if (%interval-encoded? int)
      (* (+ (%interval-semitones int) (* (%interval-octaves int) 12))
         (if (= (%interval-direction int) interval-down-flag)
             (if abs? 1 -1)
             1))
      int))

(defun interval-size (int &optional abs?)
  (if (%interval-encoded? int)
      (* (+ (%interval-letters int) (* (%interval-octaves int) 7) 1)
         (if (= (%interval-direction int) interval-down-flag)
             (if abs? 1 -1)
             1))
      int))

(defun interval-sign (int)
  (if (%interval-encoded? int)
      (%interval-sign int)
      (if (< int 0) -1 1)))

(defun complement-interval (int)
  (if (%interval-encoded? int)
      (let ((span (%interval-letters int))
            (semi (%interval-semitones int))
            (octs (%interval-octaves int)))
        (dpb (+ 3 (* (- (%interval-type int) 3) -1))
             interval-type-byte
             (dpb (mod (- 7 span) 7)
                  interval-letters-byte
                  (dpb (if (= span octs 0) 1 0)
                       interval-octaves-byte
                       (dpb (mod (- 12 semi) 12)
                            interval-semitones-byte
                            int)))))
      (mod (- 12 int) 12)))

(defun invert-interval (int)
  (if (%interval-encoded? int)
      (dpb (if (= (%interval-direction int) interval-down-flag)
               interval-up-flag
               interval-down-flag)
           interval-direction-byte
           int)
      (* int -1)))

(defun decode-interval (int)
  (if (%interval-encoded? int)
      (let ((octaves (%interval-octaves int))
            (letters (%interval-letters int)))
        (when (and (> (%interval-type int) 4) (= letters 6))
          (setf octaves (- octaves 1)))
        (when (and (< (%interval-type int) 2) (= letters 0))
          (setf octaves (+ octaves 1)))
        (list (interval-quality int)
              (* (1+ (+ letters (* 7 octaves)))
                 (%interval-sign int))))
      int))

(defun encode-interval (interval &optional letters)
  (let ((direction 1)
        (quality nil)
        (class nil)
        (semitones nil)
        (octaves nil))
    (if letters
        (progn (setf quality interval))
        (progn (setf quality (car interval))
               (setf letters (cadr interval))))
    (unless (numberp letters)
      (error "~s is not a valid interval." interval))
    (if (= letters 0)
        (error "~s is not a one-based interval (1=Unison and 8=Octave)."
               interval)
        (if (< letters 0)
            (progn (setf direction -1)
                   (setf letters (- (abs letters) 1)))
            (setf letters (- letters 1))))
    (setf octaves (floor (/ letters 7)))
    (setf letters (mod letters 7))
    (setf semitones (elt '(0 2 4 5 7 9 11) letters))
    (setf interval quality)
    (setf quality
          (position (symbol-name quality)
                    interval-names
                    :test
                    (lambda (a b)
                      (find a
                            b
                            :key
                            #'symbol-name
                            :test
                            #'string-equal))))
    (if (member letters '(0 3 4))
        (progn (setf class interval-perfect-flag)
               (case quality
                 ((0) (setf semitones (- semitones 2)))
                 ((1) (setf semitones (- semitones 1)))
                 ((3) nil)
                 ((5) (setf semitones (+ semitones 1)))
                 ((6) (setf semitones (+ semitones 2)))
                 (t
                  (error "~s invalid modifier for perfect interval ~s."
                         interval
                         (+ 1 letters)))))
        (progn (setf class interval-majmin-flag)
               (case quality
                 ((0) (setf semitones (- semitones 3)))
                 ((1) (setf semitones (- semitones 2)))
                 ((2) (setf semitones (- semitones 1)))
                 ((4) nil)
                 ((5) (setf semitones (+ semitones 1)))
                 ((6) (setf semitones (+ semitones 2)))
                 (t
                  (error "~s invalid modifier of major/minor interval ~s."
                         interval
                         (+ 1 letters))))))
    (if (>= semitones 12)
        (setf octaves (+ octaves 1))
        (if (< semitones 0) (setf octaves (- octaves 1))))
    (setf semitones (mod semitones 12))
    (setf direction
          (if (= direction -1) interval-down-flag interval-up-flag))
    (dpb interval-meta-flag
         interval-meta-byte
         (dpb class
              interval-class-byte
              (dpb quality
                   interval-type-byte
                   (dpb direction
                        interval-direction-byte
                        (dpb letters
                             interval-letters-byte
                             (dpb
                              octaves
                              interval-octaves-byte
                              (logand semitones 255)))))))))

(defparameter *tempo* 60.0)

(defparameter *beat* 0.25)

(defparameter *rhythms* (make-hash-table :size 31 :test #'equal))

(let ((entries
       '((1/64 x 64th) (1/32 t 32nd) (1/16 s 16th) (1/8 e 8th)
         (1/4 q 4er) (1/2 h) (1 w) (2 d) (4 l) (8 m))))
  (flet ((rsym (pre raw post)
           (intern (concatenate 'string
                                (if
                                 (not pre)
                                 ""
                                 (if
                                  (stringp pre)
                                  pre
                                  (symbol-name pre)))
                                (if
                                 (stringp raw)
                                 raw
                                 (symbol-name raw))
                                (if
                                 (not post)
                                 ""
                                 (if
                                  (stringp post)
                                  post
                                  (symbol-name post))))
                   :cm)))
    (dolist (e entries)
      (let ((rat (car e)))
        (dolist (s (cdr e))
          (setf (gethash s *rhythms*) rat)
          (setf (gethash (rsym 't s nil) *rhythms*) (* rat 2/3))
          (dolist (x '(("." 1/2) (".." 3/4) ("..." 7/8)))
            (let ((d (car x)) (r (cadr x)))
              (setf (gethash (rsym nil s d) *rhythms*)
                    (+ rat (* rat r)))
              (setf (gethash (rsym 't s d) *rhythms*)
                    (+ (* rat 2/3) (* rat 2/3 r))))))))))

(defmethod rhythm ((val number) &optional (tempo *tempo*)
                   (beat *beat*))
  (unless (numberp beat)
    (setf beat (parse-rhythm-string (symbol-name beat))))
  (* (/ val beat) (/ 60 tempo)))

(defmethod rhythm ((val cons) &optional (tempo *tempo*)
                   (beat *beat*))
  (loop for v in val collect (rhythm v tempo beat)))

(defparameter %rest-char #\-)

(defmethod rhythm ((val symbol) &optional (tempo *tempo*)
                   (beat *beat*))
  (let ((n (gethash val *rhythms*)))
    (if n
        (rhythm n tempo beat)
        (let* ((str (symbol-name val))
               (num
                (if (char-equal (elt str 0) %rest-char)
                    (- (parse-rhythm-string (subseq str 1)))
                    (parse-rhythm-string str))))
          (setf (gethash val *rhythms*) num)
          (rhythm (gethash val *rhythms*) tempo beat)))))

(defun parse-rhythm-string (rhythm)
  (let ((chars '(#\m #\l #\b #\w #\h #\q #\e #\s #\t #\x))
        (ops '(#\+ #\- #\* #\/)))
    (labels ((parse-rhythm-token (str)
               (let ((end (length str))
                     (pos nil)
                     (chr nil)
                     (trp nil)
                     (qup nil)
                     (sep nil)
                     (beg nil)
                     (rhy nil))
                 (if (and (> end 1)
                          (or (digit-char-p (elt str 1))
                              (find
                               (elt str 1)
                               chars
                               :test
                               #'char-equal))
                          (progn (setf
                                  trp
                                  (char-equal (elt str 0) #\t))
                                 (setf
                                  qup
                                  (char-equal (elt str 0) #\q))
                                 (setf
                                  sep
                                  (char-equal (elt str 0) #\s))
                                 (or trp qup sep)))
                     (setf beg 1)
                     (setf beg 0))
                 (setf chr (elt str beg))
                 (setf pos (position chr chars :test #'char-equal))
                 (cond (pos
                        (setf beg (+ beg 1))
                        (setf rhy (expt 2 (- pos 3))))
                       (t
                        (setf pos beg)
                        (loop with flg = nil
                              while (< beg end)
                              do (setf chr (elt str beg))
                              if (or
                                  (digit-char-p chr)
                                  (and
                                   (char= chr #\.)
                                   (not flg)
                                   (< beg (1- end))
                                   (digit-char-p (elt str (1+ beg)))
                                   (setf flg t)))
                              do (setf beg (+ beg 1))
                              else
                              do (return))
                              (if
                               (> beg pos)
                               (setf
                                rhy
                                (read-from-string
                                 (subseq str pos beg)))
                               (error "Not a rhythm: ~A" str))
                              (setf pos (+ beg 2))
                              (when
                               (and
                                (<= pos end)
                                (member
                                 (subseq str beg end)
                                 '("th" "TH" "nd" "ND" "st" "ST")))
                               (setf beg pos))))
                        (loop while (and
                                     (< beg end)
                                     (char= (elt str beg) #\.))
                              count (progn (setf beg (+ beg 1)))
                              into
                              dot
                              finally (unless
                                       (= dot 0)
                                       (setf
                                        rhy
                                        (/
                                         rhy
                                         (- 2 (expt 2 (- dot)))))))
                              (if trp (setf rhy (* rhy 3/2)))
                              (if qup (setf rhy (* rhy 5/4)))
                              (if sep (setf rhy (* rhy 7/4)))
                              (if
                               (= beg end)
                               rhy
                               (error
                                "Can't parse ~A as a rhythm."
                                str))))
                       (next-token-position (string lb len)
                         (loop with chr
                               for i from lb below len
                               do (setf chr (elt string i))
                               until (find
                                      chr
                                      ops
                                      :test
                                      #'char-equal)
                               finally (return i))))
                       (let* ((len (length rhythm))
                              (lb 0)
                              (ub
                               (next-token-position rhythm lb len)))
                         (unless (< lb ub)
                           (error "Not a rhythm: ~A" rhythm))
                         (loop with num
                               =
                               (/
                                1
                                (parse-rhythm-token
                                 (subseq rhythm lb ub)))
                               and val
                               and op
                               for i from 0
                               while (< ub len)
                               do (setf op (elt rhythm ub))
                               (setf lb (+ ub 1))
                               (setf
                                ub
                                (next-token-position rhythm lb len))
                               (unless
                                (< lb ub)
                                (error "Not a rhythm: ~A." rhythm))
                               (cond
                                ((char= op #\+)
                                 (setf
                                  val
                                  (/
                                   1
                                   (parse-rhythm-token
                                    (subseq rhythm lb ub))))
                                 (setf num (+ num val)))
                                ((char= op #\-)
                                 (setf
                                  val
                                  (/
                                   1
                                   (parse-rhythm-token
                                    (subseq rhythm lb ub))))
                                 (decf num val))
                                ((char= op #\*)
                                 (setf
                                  val
                                  (read-from-string
                                   (subseq rhythm lb ub)))
                                 (setf num (* num val)))
                                ((char= op #\/)
                                 (setf
                                  val
                                  (read-from-string
                                   (subseq rhythm lb ub)))
                                 (setf num (/ num val)))
                                ((char= op #\x)
                                 (setf
                                  val
                                  (read-from-string
                                   (subseq rhythm lb ub)))
                                 (setf
                                  num
                                  (loop repeat val collect num))))
                               finally (return num))))))

(defparameter *softest* 0.0)

(defparameter *loudest* 1.0)

(defparameter *power* 1.0)

(defparameter *logical-amplitudes* (quote
                                    (niente
                                     0
                                     pppp
                                     1/10
                                     ppp
                                     1/5
                                     pp
                                     3/10
                                     p
                                     2/5
                                     mp
                                     1/2
                                     mf
                                     3/5
                                     f
                                     7/10
                                     ff
                                     4/5
                                     fff
                                     9/10
                                     ffff
                                     1)))

(defmethod amplitude ((amp symbol) &optional (softest *softest*)
                      (loudest *loudest*) (power *power*))
  (amplitude
   (or (getf *logical-amplitudes* amp)
       (error "'~s' is not a logical amplitude." amp))
   softest loudest power))

(defmethod amplitude ((amp number) &optional (softest *softest*)
                      (loudest *loudest*) (power *power*))
  (+ softest (* (- loudest softest) (expt amp power))))

(defun lookup (num lst)
  (do ((tail lst) (last nil))
      ((or (null tail) (> (car tail) num))
       (if (not last) (cadr lst) (cadr last)))
    (setf last tail)
    (setf tail (cddr tail))))

(defun interp1 (x coords base)
  (let ((head coords))
    (let* ((x1
            (if (null coords)
                (error "bad coordinate list: ~s" head)
                (pop coords)))
           (y1
            (if (null coords)
                (error "bad coordinate list: ~s" head)
                (pop coords)))
           (x2 x1)
           (y2 y1))
      (do ()
          ((or (null coords) (> x2 x)) nil)
        (setf x1 x2)
        (setf y1 y2)
        (setf x2
              (if (null coords)
                  (error "bad coordinate list: ~s" head)
                  (pop coords)))
        (setf y2
              (if (null coords)
                  (error "bad coordinate list: ~s" head)
                  (pop coords))))
      (cond ((>= x x2) y2)
            ((<= x x1) y1)
            ((= base 1) (+ y1 (* (- x x1) (/ (- y2 y1) (- x2 x1)))))
            (t
             (let ((pct (/ (- x x1) (- x2 x1))))
               (+ y1
                  (* (/ (- y2 y1) (- base 1.0))
                     (- (expt base pct) 1.0)))))))))

(defun interpl (x coords &key min max (offset min) scale (base 1))
  (if (and offset max) (setf scale (- max offset)))
  (let ((y (interp1 x coords base)))
    (if offset
        (+ (if scale (* y scale) y) offset)
        (if scale (* y scale) y))))

(defun interp (x &rest coords) (interp1 x coords 1))

(defun tendency (x low high &key min max (offset min) scale
                 (ranfn #'random) (state *random-state*) &aux value)
  (if (and offset max) (setf scale (- max offset)))
  (when (consp low) (setf low (interp1 x low 1)))
  (when (consp high) (setf high (interp1 x high 1)))
  (when (> low high) (rotatef low high))
  (setf value
        (if (= low high)
            low
            (+ low (funcall ranfn (* 1.0 (- high low)) state))))
  (when scale (setf value (* value scale)))
  (if offset (+ value offset) value))

(defun rescale-envelope (env &key x-min x-max y-min y-max)
  (let ((minx nil) (miny nil) (maxx nil) (maxy nil))
    (loop for tail on env by #'cddr
          for x = (car tail)
          for y = (cadr tail)
          do (unless minx (setf minx x))
             (setf maxx x)
             (if miny (setf miny (min miny y)) (setf miny y))
             (if maxy (setf maxy (max maxy y)) (setf maxy y)))
          (if (and (or x-min x-max) (or y-min y-max))
              (progn (or x-min (setf x-min minx))
                     (or x-max (setf x-max maxx))
                     (or y-min (setf y-min miny))
                     (or y-max (setf y-max maxy))
                     (loop for tail on env by #'cddr
                           for x = (car tail)
                           for y = (cadr tail)
                           collect (rescale x minx maxx x-min x-max)
                           collect (rescale
                                    y
                                    miny
                                    maxy
                                    y-min
                                    y-max)))
                     (if (or x-min x-max)
                         (progn (or x-min (setf x-min minx))
                                (or x-max (setf x-max maxx))
                                (loop for tail on env by #'cddr
                                 for x = (car tail)
                                 for y = (cadr tail)
                                 collect (rescale
                                          x
                                          minx
                                          maxx
                                          x-min
                                          x-max)
                                 collect y))
                                (progn
                                 (or y-min (setf y-min miny))
                                 (or y-max (setf y-max maxy))
                                 (loop for tail on env by #'cddr
                                  for x = (car tail)
                                  for y = (cadr tail)
                                  collect x
                                  collect (rescale
                                           y
                                           miny
                                           maxy
                                           y-min
                                           y-max)))))))

(defun quantize (value step) (* (floor (+ (/ value step) 1/2)) step))

(defun rescale (value oldmin oldmax newmin newmax)
  (+ (* (/ (- newmax newmin) (- oldmax oldmin)) (- value oldmin))
     newmin))

(defun mymod (num div)
  (if (and (integerp num) (integerp div))
      (mod num div)
      (let* ((res (/ num div)) (flo (floor res)))
        (- num (* flo div)))))

(defun fit (number lb ub &optional (mode :reflect))
  (when (> lb ub) (rotatef lb ub))
  (if (<= lb number ub)
      number
      (let ((b (if (> number ub) ub lb)) (r (- ub lb)))
        (case mode
          ((:limit) b)
          ((:reflect)
           (let* ((2r (* 2 r)) (v (rem (- number b) 2r)))
             (+ (if (> (abs v) r)
                    (funcall (if (>= v 0) #'- #'+) v 2r)
                    (- v))
                b)))
          ((:wrap) (+ (if (= b ub) lb ub) (rem (- number b) r)))
          (t (error "~s is not :limit, :reflect or :wrap" mode))))))

(defun cents->scaler (cents) (expt 2 (/ cents 1200)))

(defun scaler->cents (scaler) (round (* (log2 scaler) 1200)))

(defun between (lb ub &optional exception (state *random-state*))
  (let ((range (- ub lb)))
    (if (not (> range 0))
        lb
        (if exception
            (loop for num = (+ lb (random range state))
                  when (not (= exception num))
                    return num)
                    (+ lb (random range state))))))

(defun pick (&rest args) (elt args (random (length args))))

(defun pickl (seq &key (end (length seq)) (start 0) avoid
              (state *random-state*))
  (let ((range (- end start)))
    (if avoid
        (loop with x = avoid
              while (eq x avoid)
              do (setf x (elt seq (+ start (random range state))))
              finally (return x))
              (elt seq (+ start (random range state))))))

(defun vary (value variance &optional (where :around)
             (state *random-state*))
  (if (or (<= variance 0) (= value 0))
      value
      (let ((vary (random (abs (* value variance 1.0)) state)))
        (case where
          ((:center :around)
           (+ (- value (abs (* value variance 0.5))) vary))
          ((:above) (+ value vary))
          ((:below) (- value vary))
          (t
           (error "~s is not :center :around :above or :below"
                  where))))))

(defun drunk (n width &key (low most-negative-fixnum)
              (high most-positive-fixnum) (mode :reflect) (avoid nil)
              (state *random-state*))
  (let ((amt (between (- width) width avoid state)))
    (incf n amt)
    (unless (<= low n high)
      (cond ((eq mode ':reflect) (setf n (fit n low high)))
            ((eq mode ':reset) (setf n (+ low (/ (- high low) 2))))
            ((eq mode ':jump) (setf n (between low high)))
            ((eq mode ':limit) (setf n (max low (min n high))))
            ((eq mode ':stop) (setf n nil))
            ((numberp mode) (setf n mode))
            (t
             (error "~s is not :refect :reset :jump  :limit or :stop."
                    mode))))
    n))

(defun odds (n &optional (if-true-val t) (if-false-val nil)
             (state *random-state*))
  (if (< (random 1.0 state) n) if-true-val if-false-val))

(defun shuffle (seq &key (start 0) (end (length seq))
                (state *random-state*) (copy t) &aux
                (width (- end start)))
  (if (< width 2)
      seq
      (progn (when copy (setf seq (copy-list seq)))
             (loop for i from start to (- end 1)
                   for j = (+ start (random width state))
                   for v = (elt seq i)
                   do (setf (elt seq i) (elt seq j))
                      (setf (elt seq j) v))
                   seq)))

(defun ran (&key (type ':uniform) from (below 1.0)
            (state *random-state*) a b distribution)
  (let ((num nil) (res nil))
    (if (and from below)
        (progn (when (< below from) (rotatef below from))
               (setf num (- below from)))
        (setf num
              (or below
                  (error "Missing ':below' (upper bound value)."))))
    (flet ((betad (a b s)
             (loop with 1/a = (/ 1 a)
                   and 1/b = (/ 1 b)
                   for r1 = (random 1.0 s)
                   for r2 = (random 1.0 s)
                   for y1 = (expt r1 1/a)
                   for y2 = (expt r2 1/b)
                   for
                   sum = (+ y1 y2)
                   while (> sum 1.0)
                   finally (return (/ y1 sum))))
             (gaussian (s)
               (let ((a (random 1.0 s)) (b (random 1.0 s)))
                 (* (sqrt (* -2.0 (log (- 1 a))))
                    (cos (* 6.2831855 b)))))
             (exp2 (l s)
               (let ((u nil) (v nil) (2*e^-1 (* 2 (exp -1.0))))
                 (loop do (setf u (- 1.0 (random 1.0 s)))
                          (setf v (* 2*e^-1 (random 1.0 s)))
                       until (<= v (* -2.0 u (log u)))
                       finally (return (/ v u l)))))
               (cauchy (pos? s)
                 (let ((r (* (if pos? 1.5707964 pi) (random 1.0 s))))
                   (/ (sin r) (cos r))))
               (poisson (l s)
                 (if (< l 0)
                     (error "Lambda parameter ~s to poisson is negative"
                            l))
                 (let ((b (exp (- l))) (n 0))
                   (loop for p = (random 1.0 s) then
                             (* p (random 1.0 s))
                         do (incf n)
                         until (< p b))
                         n))
                 (cheezy-gamma (nu s)
                   (let ((r 1))
                     (loop repeat (round nu)
                           do (setf r (* r (- 1 (random 1.0 s)))))
                           (- (log r)))))
                 (case (or distribution type)
                   ((:uniform :u uniform u)
                    (setf res (random num state)))
                   ((:low :lp :low-pass lp low-pass)
                    (setf res
                          (min (random num state)
                               (random num state))))
                   ((:high :hp :high-pass hp high-pass)
                    (setf res
                          (max (random num state)
                               (random num state))))
                   ((:mean :triangular :bp :band-pass bp band-pass)
                    (setf res
                          (/ (+
                              (random num state)
                              (random num state))
                             2)))
                   ((:beta beta)
                    (if a
                        (if b nil (setf b a))
                        (if b
                            (setf a b)
                            (progn (setf a 0.5) (setf b 0.5))))
                    (setf res (* num (betad a b state))))
                   ((:slow-exp slow-exp)
                    (setf res (* num (exp2 a state))))
                   ((:exponential exponential :exp exp)
                    (setf res
                          (* num
                             (/
                              (- (log (- 1 (random 1.0 state))))
                              a))))
                   ((:cauchy cauchy)
                    (setf res (* num (cauchy a state))))
                   ((:poisson poisson)
                    (setf res (* num (poisson a state))))
                   ((:gamma gamma)
                    (setf res (* num (cheezy-gamma a state))))
                   ((:gaussian gaussian :gauss gauss)
                    (setf res (* num (gaussian state))))
                   (t
                    (error "~s is not a random distribution type."
                           (or distribution type))))
                 (if from (+ from res) res))))

(defun ransegs (num &key (type ':uniform) (min 0.0 mnp) (max 1.0 mxp)
                (sum 1.0 smp) a b)
  (if smp (setf max sum))
  (if (not (< min max))
      (error "Minimum value ~s not less than maximum ~s." min max))
  (if (and smp (or mnp mxp))
      (error "sum ~s: keyword :sum not allowed with :min or :max."
             sum))
  (let ((done (if (not smp) num (+ num 1)))
        (segs (list))
        (mini most-positive-fixnum)
        (sums 0)
        (maxi most-negative-fixnum))
    (do ((i 0)
         (r (ran :type type :a a :b b) (ran :type type :a a :b b)))
        ((= i done)
         (setf segs (sort segs #'<))
         (setf mini (first segs)))
      (unless (member r segs)
        (setf segs (cons r segs))
        (setf sums (+ sums r))
        (if (> r maxi) (setf maxi r))
        (setf i (+ i 1))))
    (do ((tail (cdr segs) (cdr tail)))
        ((null (cdr tail))
         (rplaca segs min)
         (rplaca tail max)
         (if (not smp)
             segs
             (do ((last segs (cdr last))
                  (tail (cdr segs) (cdr tail))
                  (prev nil))
                 ((null tail) (rplacd prev (list)) segs)
               (setf prev last)
               (rplaca last (- (car tail) (car last))))))
      (rplaca tail (rescale (car tail) mini maxi min max)))))

(defun expl (power &key (y0 0.0) (y1 1.0) (base 2))
  (unless (<= 0 power 1)
    (error "Power ~s is not between 0 and 1." power))
  (if (= base 1)
      (+ y0 (* (- y1 y0) power))
      (+ y0
         (* (/ (- y1 y0) (- base 1.0)) (- (expt base power) 1.0)))))

(defun explsegs (len sum power)
  (if (= len 0)
      '()
      (loop for i from 1 to len
            for l = 0 then v
            for v = (expl (/ i len) :base power)
            collect (* sum (- v l)))))

(defun explseg (i len num power)
  (if (>= i len)
      (* 0 num)
      (* num
         (- (expl (/ (+ i 1) len) :base power)
            (if (<= i 0) 0 (expl (/ i len) :base power))))))

(defun geosegs (len sum base)
  (if (= len 0)
      nil
      (let ((a (* sum (/ (- 1 base) (- 1 (expt base len))))))
        (loop for n from 0 below len
              collect a
              do (setf a (* a base))))))

(defun geoseg (i len sum base)
  (if (>= i len)
      (* 0 sum)
      (let ((a (* sum (/ (- 1 base) (- 1 (expt base len))))))
        (* a (expt base i)))))

(defmacro doeach (pars &body forms)
  (unless (consp pars)
    (error "doeach: ~s not list (var source &optional return)" pars))
  (let* ((args pars)
         (var (pop args))
         (source (pop args))
         (retrn (if (null args) nil (pop args))))
    (let ((src (gensym)))
      `(let ((,var ,source))
         (if (consp ,var)
             (let ((,src ,var)) (dolist (,var ,src ,retrn) ,@forms))
             (progn ,@forms ,retrn))))))

(defun encode-set (notes)
  (let ((set 0))
    (dolist (e notes)
      (setf set (logior set (ash 1 (mod (keynum e) 12)))))
    set))

(defun decode-set (set)
  (loop for i below 12 when (= (ldb (byte 1 i) set) 1) collect i))

(defun encode-inverse-set (notes)
  (let ((set 0))
    (dolist (e notes)
      (setf set (logior set (ash 1 (mod (- (keynum e)) 12)))))
    set))

(defun best-normal-form (set)
  (let ((min most-positive-fixnum) (transp nil) (byt (byte 1 11)))
    (dotimes (i 12)
      (when (< set min)
        (setf min set)
        (setf transp (mod (- 12 i) 12)))
      (setf set (logand (logior (ldb byt set) (ash set 1)) 4095)))
    (values min transp)))

(defun prime-form (notes &optional dont-decode)
  (let ((bnf nil) (tr nil) (tr2 nil) (ibnf nil))
    tr2
    (multiple-value-setq (bnf tr)
      (best-normal-form (encode-set notes)))
    (multiple-value-setq (ibnf tr2)
      (best-normal-form (encode-inverse-set notes)))
    (if (< bnf ibnf)
        (values (if dont-decode bnf (decode-set bnf)) tr)
        (values (if dont-decode ibnf (decode-set ibnf)) tr))))

(defun markov-analyze (seq &key (order 1) (print? t) (pattern? t)
                       sort? (print-decimals 3) key)
  (let ((len (length seq))
        (labels '())
        (table '())
        (row-label-width 8)
        (pat nil)
        (field (+ print-decimals 2)))
    (labels ((add-outcome (prev next)
               (let ((entry
                      (find prev table :test #'equal :key #'car)))
                 (if (not entry)
                     (push (list prev
                                 (format nil "~s" prev)
                                 (list next 1))
                           table)
                     (let ((e (assoc next (cddr entry))))
                       (if e
                           (rplaca (cdr e) (+ 1 (cadr e)))
                           (rplacd (last (cdr entry))
                                   (list (list next 1))))))))
             (before? (x y l)
               (if (null x)
                   t
                   (let ((p1 (position (car x) l :test #'equal))
                         (p2 (position (car y) l :test #'equal)))
                     (cond ((< p1 p2) t)
                           ((= p1 p2) (before? (cdr x) (cdr y) l))
                           (t nil)))))
             (liststring (l)
               (if (null l)
                   ""
                   (let ((a (format nil "~s" (car l))))
                     (do ((x (cdr l) (cdr x)))
                         ((null x) a)
                       (setf a
                             (concatenate
                              'string
                              a
                              (format nil " ~s" (car x)))))))))
      (dotimes (i len)
        (loop with prev = (list)
              for j to order
              for x =
                  (let ((raw (elt seq (mod (+ i j) len))))
                    (if key (funcall key raw) raw))
              when (< j order) do (push x prev)
              finally (progn (add-outcome (reverse prev) x)
                             (or (find x labels) (push x labels)))))
        (cond ((consp sort?) (setf labels sort?))
              (sort? (setf labels (sort labels sort?)))
              ((numberp (car labels))
               (setf labels (sort labels #'<)))
              ((and (car labels)
                    (let ((t2 (car labels))) (and t2 (symbolp t2))))
               (setf labels
                     (sort labels
                           (lambda (x y)
                             (string-lessp
                              (format nil "~a" x)
                              (format nil "~a" y))))))
              (t (setf labels (reverse labels))))
        (loop for row in table
              for lab = (cadr row)
              for val = (cddr row)
              maximize (length lab) into len
              do (let ((total (loop for e in val sum (cadr e))))
                       (setf total (* total 1.0))
                       (loop for e in val
                             do (rplaca
                                 (cdr e)
                                 (decimals
                                  (/ (cadr e) total)
                                  print-decimals))))
                   finally (setf row-label-width
                                 (max len row-label-width)))
                   (setf table
                         (sort table
                               #'(lambda
                                  (x y)
                                  (before? (car x) (car y) labels))))
                   (when (member print? '(t table :table))
                     (let* ((sp " ")
                            (ln
                             (make-string
                              field
                              :initial-element
                              #\-)))
                       (progn (terpri)
                              (dotimes
                               (i row-label-width)
                               (write-char #\*))
                              (dolist
                               (l labels)
                               (princ sp)
                               (let*
                                ((s (format nil "~a" l))
                                 (n (length s)))
                                (dotimes
                                 (i (max (- field n) 0))
                                 (write-char #\Space))
                                (princ s))))
                       (dolist (row table)
                         (terpri)
                         (let* ((s (liststring (car row)))
                                (n (length s)))
                           (dotimes (i (max (- row-label-width n) 0))
                             (write-char #\Space))
                           (dotimes (i (min row-label-width n))
                             (write-char (elt s i))))
                         (dolist (l labels)
                           (let ((v (assoc l (cddr row))))
                             (if
                              (not v)
                              (progn (princ sp) (princ ln))
                              (let*
                               ((s (prin1-to-string (cadr v)))
                                (n (length s)))
                               (princ sp)
                               (dotimes
                                (i (max (- field n) 0))
                                (write-char #\Space))
                               (princ s))))))
                       (terpri)))
                   (when (or pattern?
                             (member print? '(t pattern :pattern)))
                     (setf pat
                           (loop for row in table
                                 collect (append
                                          (car row)
                                          '(->)
                                          (cddr row)))))
                     (when (member print? '(t pattern :pattern))
                       (pprint `(new markov of ',pat)))
                     (if pattern?
                         (make-instance (find-class 'markov) :of pat)
                         (values)))))

(defun histogram (numbers lo hi slots)
  (let ((hist (make-list slots :initial-element 0)) (rang (- hi lo)))
    (loop with i
          for x in numbers
          if (and (>= x lo) (< x hi))
            do (setf i (floor (* slots (/ (- x lo) rang))))
               (setf (elt hist i) (+ (elt hist i) 1)))
            hist))
