mirror of
https://github.com/cookiengineer/audacity
synced 2025-04-30 15:49:41 +02:00
2377 lines
79 KiB
Common Lisp
2377 lines
79 KiB
Common Lisp
;; X-Music, inspired by Commmon Music
|
|
|
|
#|
|
|
PATTERN SEMANTICS
|
|
|
|
Patterns are objects that are generally accessed by calling
|
|
(next pattern). Each call returns the next item in an
|
|
infinite sequence generated by the pattern. Items are
|
|
organized into periods. You can access all (remaining)
|
|
items in the current period using (next pattern t).
|
|
|
|
Patterns mark the end-of-period with +eop+, a distinguished
|
|
atom. The +eop+ markers are filtered out by the next function
|
|
but returned by the :next method.
|
|
|
|
Pattern items may be patterns. This is called a nested
|
|
pattern. When patterns are nested, you return a period
|
|
from the innermost pattern, i.e. traversal is depth-first.
|
|
This means when you are using something like random, you
|
|
have to remember the last thing returned and keep getting
|
|
the next element from that thing until you see +eop+;
|
|
then you move on. It's a bit more complicated because
|
|
a pattern advances when its immediate child pattern
|
|
finishes a cycle, but +eop+ is only returned from the
|
|
"leaf" patterns.
|
|
|
|
With nested patterns, i.e. patterns with items that
|
|
are patterns, the implementation requires that
|
|
*all* items must be patterns. The application does
|
|
*not* have to make every item a pattern, so the
|
|
implementation "cleans up" the item list: Any item
|
|
that is not a pattern is be replaced with a cycle
|
|
pattern whose list contains just the one item.
|
|
|
|
EXPLICIT PATTERN LENGTH
|
|
|
|
Pattern length may be given explicitly by a number or
|
|
a pattern that generates numbers. Generally this is
|
|
specified as the optional :for keyword parameter when
|
|
the pattern is created. If the explicit pattern
|
|
length is a number, this will be the period length,
|
|
overriding all implicit lengths. If the pattern length
|
|
is itself a pattern, the pattern is evaluated every
|
|
period to determine the length of the next period,
|
|
overriding any implicit length.
|
|
|
|
IMPLEMENTATION
|
|
|
|
There are 3 ways to determine lengths:
|
|
1) The length is implicit. The length can be
|
|
computed (at some point) and turned into an
|
|
explicit length.
|
|
|
|
2) The length is explicit. This overrides the
|
|
implicit length. The explicit length is stored as
|
|
a counter that tells how many more items to generate
|
|
in the current period.
|
|
|
|
3) The length can be generated by a pattern.
|
|
The pattern is evaluated to generate an explicit
|
|
length.
|
|
|
|
So ultimately, we just need a mechanism to handle
|
|
explicit lengths. This is incorporated into the
|
|
pattern-class. The pattern-class sends :start-period
|
|
before calling :advance when the first item in a
|
|
period is about to be generated. Also, :next returns
|
|
+eop+ automatically at the end of a period.
|
|
|
|
Because evaluation is "depth first," i.e. we
|
|
advance to the next top-level item only after a period
|
|
is generated from a lower-level pattern, every pattern
|
|
has a "current" field that holds the current item. the
|
|
"have-current" field is a flag to tell when the "current"
|
|
field is valid. It is initialized to nil.
|
|
|
|
To generate an element, you need to follow the nested
|
|
patterns all the way to the leaf pattern for every
|
|
generated item. This is perhaps less efficient than
|
|
storing the current leaf pattern at the top level, but
|
|
patterns can be shared, i.e. a pattern can be a
|
|
sub-pattern of multiple patterns, so current position
|
|
in the tree structure of patterns can change at
|
|
any time.
|
|
|
|
The evaluation of nested patterns is depth-first
|
|
and the next shallower level advances when its current
|
|
child pattern completes a cycle. To facilitate this
|
|
step, the :advance method, which advances a pattern
|
|
and computes "current", returns +eonp+, which is a
|
|
marker that a nested pattern has completed a cycle.
|
|
|
|
The :next method generates the next item or +eop+ from
|
|
a pattern. The algorithm in psuedo-code is roughly this:
|
|
|
|
next(p)
|
|
while true:
|
|
if not have-current
|
|
pattern-advance()
|
|
have-current = true
|
|
if is-nested and current = eop:
|
|
have-current = false
|
|
return eonp
|
|
if is-nested:
|
|
rslt = next(current)
|
|
if rslt == eonp
|
|
have-current = false
|
|
elif rslt == eop and not current.is-nested
|
|
have-current = false
|
|
return rslt
|
|
else
|
|
return rslt
|
|
else
|
|
have-current = nil
|
|
return current
|
|
|
|
pattern-advance
|
|
// length-pattern is either a pattern or a constant
|
|
if null(count) and length-pattern:
|
|
count = next(length-pattern)
|
|
start-period() // subclass-specific computation
|
|
if null(count)
|
|
error
|
|
if count == 0
|
|
current = eop
|
|
count = nil
|
|
else
|
|
advance() // subclass-specific computation
|
|
count--
|
|
|
|
|
|
SUBCLASS RESPONSIBILITIES
|
|
|
|
Note that :advance is the method to override in the
|
|
various subclasses of pattern-class. The :advance()
|
|
method computes the next element in the infinite
|
|
sequence of items and puts the item in the "current"
|
|
field.
|
|
|
|
The :start-period method is called before calling
|
|
advance to get the first item of a new period.
|
|
|
|
Finally, set the is-nested flag if there are nested patterns,
|
|
and make all items of any nested pattern be patterns (no
|
|
mix of patterns and non-patterns is allowed; use
|
|
(MAKE-CYCLE (LIST item))
|
|
to convert a non-pattern to a pattern).
|
|
|
|
|#
|
|
|
|
(setf SCORE-EPSILON 0.000001)
|
|
|
|
(setf pattern-class
|
|
(send class :new '(current have-current is-nested name count
|
|
length-pattern trace)))
|
|
|
|
(defun patternp (x)
|
|
(and (objectp x) (send x :isa pattern-class)))
|
|
|
|
(setf +eop+ '+eop+)
|
|
(setf +eonp+ '+eonp+) ;; end of nested period, this indicates you
|
|
;; should advance yourself and call back to get the next element
|
|
|
|
(defun check-for-list (lis name)
|
|
(if (not (listp lis))
|
|
(error (format nil "~A, requires a list of elements" name))))
|
|
|
|
(defun check-for-list-or-pattern (lis name)
|
|
(if (not (or (listp lis) (patternp lis)))
|
|
(error (format nil "~A, requires a list of elements or a pattern" name))))
|
|
|
|
(defun list-has-pattern (lis)
|
|
(dolist (e lis)
|
|
(if (patternp e) (return t))))
|
|
|
|
(defun is-homogeneous (lis)
|
|
(let (type)
|
|
(dolist (elem lis t)
|
|
(cond ((null type)
|
|
(setf type (if (patternp elem) 'pattern 'atom)))
|
|
((and (eq type 'pattern)
|
|
(not (patternp elem)))
|
|
(return nil))
|
|
((and (eq type 'atom)
|
|
(patternp elem))
|
|
(return nil))))))
|
|
|
|
(defun make-homogeneous (lis)
|
|
(cond ((is-homogeneous lis) lis)
|
|
(t
|
|
(mapcar #'(lambda (item)
|
|
(if (patternp item) item
|
|
(make-cycle (list item)
|
|
;; help debugging by naming the new pattern
|
|
;; probably, the name could be item, but
|
|
;; here we coerce item to a string to avoid
|
|
;; surprises in code that assumes string names.
|
|
:name (format nil "~A" item))))
|
|
lis))))
|
|
|
|
|
|
(send pattern-class :answer :next '()
|
|
'(;(display ":next" name is-nested)
|
|
(loop
|
|
(cond ((not have-current)
|
|
(send self :pattern-advance)
|
|
(setf have-current t)
|
|
(cond (trace
|
|
(format t "pattern ~A advanced to ~A~%"
|
|
(if name name "<no-name>")
|
|
(if (patternp current)
|
|
(if (send current :name)
|
|
(send current :name)
|
|
"<a-pattern>")
|
|
current))))
|
|
(cond ((and is-nested (eq current +eop+))
|
|
;(display ":next returning eonp" name)
|
|
(setf have-current nil)
|
|
(return +eonp+)))))
|
|
(cond (is-nested
|
|
(let ((rslt (send current :next)))
|
|
(cond ((eq rslt +eonp+)
|
|
(setf have-current nil))
|
|
;; advance next-to-leaf level at end of leaf's period
|
|
((and (eq rslt +eop+) (not (send current :is-nested)))
|
|
(setf have-current nil)
|
|
;; return +eof+ because it's the end of leaf's period
|
|
(return rslt))
|
|
(t
|
|
(return rslt)))))
|
|
(t
|
|
(setf have-current nil)
|
|
(return current))))))
|
|
|
|
|
|
;; :PATTERN-ADVANCE -- advance to the next item in a pattern
|
|
;;
|
|
;; this code is used by every class. class-specific behavior
|
|
;; is implemented by :advance, which this method calls
|
|
;;
|
|
(send pattern-class :answer :pattern-advance '()
|
|
'(;(display "enter :pattern-advance" self name count current is-nested)
|
|
(cond ((null count)
|
|
;(display "in :pattern-advance" name count length-pattern)
|
|
(if length-pattern
|
|
(setf count (next length-pattern)))
|
|
;; if count is still null, :start-period must set count
|
|
(send self :start-period)))
|
|
(cond ((null count)
|
|
(error
|
|
(format nil
|
|
"~A, pattern-class :pattern-advance has null count" name))))
|
|
(cond ((zerop count)
|
|
(setf current +eop+)
|
|
(setf count nil))
|
|
(t
|
|
(send self :advance)
|
|
(decf count)))
|
|
;(display "exit :pattern-advance" name count current)
|
|
))
|
|
|
|
|
|
(send pattern-class :answer :is-nested '() '(is-nested))
|
|
|
|
|
|
(send pattern-class :answer :name '() '(name))
|
|
|
|
|
|
(send pattern-class :answer :set-current '(c)
|
|
'((setf current c)
|
|
(let ((value
|
|
(if (patternp current)
|
|
(send current :name)
|
|
current)))
|
|
;(display ":set-current" name value)
|
|
)))
|
|
|
|
|
|
;; next -- get the next element in a pattern
|
|
;;
|
|
;; any non-pattern value is simply returned
|
|
;;
|
|
(defun next (pattern &optional period-flag)
|
|
;(display "next" pattern period-flag (patternp pattern))
|
|
(cond ((and period-flag (patternp pattern))
|
|
(let (rslt elem)
|
|
(while (not (eq (setf elem (send pattern :next)) +eop+))
|
|
;(display "next t" (send pattern :name) elem)
|
|
(if (not (eq elem +eonp+))
|
|
(push elem rslt)))
|
|
(reverse rslt)))
|
|
(period-flag
|
|
(display "next" pattern)
|
|
(error (format nil "~A, next expected a pattern"
|
|
(send pattern :name))))
|
|
((patternp pattern)
|
|
;(display "next" (send pattern :name) pattern)
|
|
(let (rslt)
|
|
(dotimes (i 10000 (error
|
|
(format nil
|
|
"~A, just retrieved 10000 empty periods -- is there a bug?"
|
|
(send pattern :name))))
|
|
(if (not (member (setf rslt (send pattern :next))
|
|
'(+eop+ +eonp+)))
|
|
(return rslt)))))
|
|
(t ;; pattern not a pattern, so just return it:
|
|
;(display "next" pattern)
|
|
pattern)))
|
|
|
|
;; ---- LENGTH Class ----
|
|
|
|
(setf length-class
|
|
(send class :new '(pattern length-pattern) '() pattern-class))
|
|
|
|
(send length-class :answer :isnew '(p l nm tr)
|
|
'((setf pattern p length-pattern l name nm trace tr)))
|
|
|
|
;; note that count is used as a flag as well as a counter.
|
|
;; If count is nil, then the pattern-length has not been
|
|
;; determined. Count is nil intitially and again at the
|
|
;; end of each period. Otherwise, count is an integer
|
|
;; used to count down the number of items remaining in
|
|
;; the period.
|
|
|
|
(send length-class :answer :start-period '()
|
|
'((setf count (next length-pattern))))
|
|
|
|
(send length-class :answer :advance '()
|
|
'((send self :set-current (next pattern))))
|
|
|
|
(defun make-length (pattern length-pattern &key (name "length") trace)
|
|
(send length-class :new pattern length-pattern name trace))
|
|
|
|
;; ---- CYCLE Class ---------
|
|
|
|
(setf cycle-class (send class :new
|
|
'(lis cursor lis-pattern)
|
|
'() pattern-class))
|
|
|
|
(send cycle-class :answer :isnew '(l for nm tr)
|
|
'((cond ((patternp l)
|
|
(setf lis-pattern l))
|
|
((listp l)
|
|
(send self :set-list l))
|
|
(t
|
|
(error (format nil "~A, expected list" nm) l)))
|
|
(setf length-pattern for name nm trace tr)))
|
|
|
|
|
|
(send cycle-class :answer :set-list '(l)
|
|
'((setf lis l)
|
|
(check-for-list lis "cycle-class :set-list")
|
|
(setf is-nested (list-has-pattern lis))
|
|
(setf lis (make-homogeneous lis))))
|
|
|
|
|
|
(send cycle-class :answer :start-period '()
|
|
'(;(display "cycle-class :start-period" lis-pattern lis count length-pattern)
|
|
(cond (lis-pattern
|
|
(send self :set-list (next lis-pattern t))
|
|
(setf cursor lis)))
|
|
(if (null count)
|
|
(setf count (length lis)))))
|
|
|
|
|
|
(send cycle-class :answer :advance '()
|
|
'((cond ((and (null cursor) lis)
|
|
(setf cursor lis))
|
|
((null cursor)
|
|
(error (format nil "~A, :advance - no items" name))))
|
|
(send self :set-current (car cursor))
|
|
(pop cursor)))
|
|
|
|
|
|
(defun make-cycle (lis &key for (name "cycle") trace)
|
|
(check-for-list-or-pattern lis "make-cycle")
|
|
(send cycle-class :new lis for name trace))
|
|
|
|
;; ---- LINE class ----
|
|
|
|
(setf line-class (send class :new '(lis cursor lis-pattern)
|
|
'() pattern-class))
|
|
|
|
(send line-class :answer :isnew '(l for nm tr)
|
|
'((cond ((patternp l)
|
|
(setf lis-pattern l))
|
|
((listp l)
|
|
(send self :set-list l))
|
|
(t
|
|
(error (format nil "~A, expected list" nm) l)))
|
|
(setf length-pattern for name nm trace tr)))
|
|
|
|
(send line-class :answer :set-list '(l)
|
|
'((setf lis l)
|
|
(check-for-list lis "line-class :set-list")
|
|
(setf is-nested (list-has-pattern lis))
|
|
(setf lis (make-homogeneous l))
|
|
(setf cursor lis)))
|
|
|
|
|
|
(send line-class :answer :start-period '()
|
|
'((cond (lis-pattern
|
|
(send self :set-list (next lis-pattern t))
|
|
(setf cursor lis)))
|
|
(if (null count)
|
|
(setf count (length lis)))))
|
|
|
|
|
|
(send line-class :answer :advance '()
|
|
'((cond ((null cursor)
|
|
(error (format nil "~A, :advance - no items" name))))
|
|
(send self :set-current (car cursor))
|
|
(if (cdr cursor) (pop cursor))))
|
|
|
|
|
|
(defun make-line (lis &key for (name "line") trace)
|
|
(check-for-list-or-pattern lis "make-line")
|
|
(send line-class :new lis for name trace))
|
|
|
|
|
|
;; ---- RANDOM class -----
|
|
|
|
(setf random-class (send class :new
|
|
'(lis lis-pattern len previous repeats mincnt maxcnt)
|
|
'() pattern-class))
|
|
|
|
;; the structure is (value weight weight-pattern max min)
|
|
(setfn rand-item-value car)
|
|
(defun set-rand-item-value (item value) (setf (car item) value))
|
|
(setfn rand-item-weight cadr)
|
|
(defun set-rand-item-weight (item weight) (setf (car (cdr item)) weight))
|
|
(setfn rand-item-weight-pattern caddr)
|
|
(setfn rand-item-max cadddr)
|
|
(defun rand-item-min (lis) (car (cddddr lis)))
|
|
|
|
|
|
(defun select-random (len lis previous repeats mincnt maxcnt)
|
|
(let (sum items r)
|
|
(cond ((zerop len)
|
|
(break "random-class has no list to choose from")
|
|
nil)
|
|
(t
|
|
(setf sum 0)
|
|
(dolist (item lis)
|
|
(setf sum (+ sum (rand-item-weight item))))
|
|
(setf items lis)
|
|
(setf r (rrandom))
|
|
(setf sum (* sum r))
|
|
(setf rbd-count-all (incf rbd-count-all))
|
|
(loop
|
|
(setf sum (- sum (rand-item-weight (car items))))
|
|
(if (<= sum 0) (return (car items)))
|
|
(setf rbd-count-two (incf rbd-count-two))
|
|
(setf items (cdr items)))))))
|
|
|
|
|
|
(defun random-convert-spec (item)
|
|
;; convert (value :weight wp :min min :max max) to (value nil wp max min)
|
|
(let (value (wp 1) mincnt maxcnt lis)
|
|
(setf value (car item))
|
|
(setf lis (cdr item))
|
|
(while lis
|
|
(cond ((eq (car lis) :weight)
|
|
(setf wp (cadr lis)))
|
|
((eq (car lis) :min)
|
|
(setf mincnt (cadr lis)))
|
|
((eq (car lis) :max)
|
|
(setf maxcnt (cadr lis)))
|
|
(t
|
|
(error "(make-random) item syntax error" item)))
|
|
(setf lis (cddr lis)))
|
|
(list value nil wp maxcnt mincnt)))
|
|
|
|
|
|
(defun random-atom-to-list (a)
|
|
(if (atom a)
|
|
(list a nil 1 nil nil)
|
|
(random-convert-spec a)))
|
|
|
|
|
|
(send random-class :answer :isnew '(l for nm tr)
|
|
;; there are two things we have to normalize:
|
|
;; (1) make all items lists
|
|
;; (2) if any item is a pattern, make all items patterns
|
|
'((cond ((patternp l)
|
|
(setf lis-pattern l))
|
|
((listp l)
|
|
(send self :set-list l))
|
|
(t
|
|
(error (format nil "~A, expected list") l)))
|
|
(setf rbd-count-all 0 rbd-count-two 0)
|
|
(setf length-pattern for name nm trace tr)))
|
|
|
|
|
|
(send random-class :answer :set-list '(l)
|
|
'((check-for-list l "random-class :set-list")
|
|
(setf lis (mapcar #'random-atom-to-list l))
|
|
(dolist (item lis)
|
|
(if (patternp (rand-item-value item))
|
|
(setf is-nested t)))
|
|
(if is-nested
|
|
(mapcar #'(lambda (item)
|
|
(if (not (patternp (rand-item-value item)))
|
|
(set-rand-item-value item
|
|
(make-cycle (list (rand-item-value item))))))
|
|
lis))
|
|
;(display "random is-new" lis)
|
|
(setf repeats 0)
|
|
(setf len (length lis))))
|
|
|
|
|
|
(send random-class :answer :start-period '()
|
|
'(;(display "random-class :start-period" count len lis lis-pattern)
|
|
(cond (lis-pattern
|
|
(send self :set-list (next lis-pattern t))))
|
|
(if (null count)
|
|
(setf count len))
|
|
(dolist (item lis)
|
|
(set-rand-item-weight item (next (rand-item-weight-pattern item))))))
|
|
|
|
|
|
(send random-class :answer :advance '()
|
|
'((let (selection (iterations 0))
|
|
;(display "random-class :advance" mincnt repeats)
|
|
(cond ((and mincnt (< repeats mincnt))
|
|
(setf selection previous)
|
|
(incf repeats))
|
|
(t
|
|
(setf selection
|
|
(select-random len lis previous repeats mincnt maxcnt))))
|
|
(loop ; make sure selection is ok, otherwise try again
|
|
(cond ((and (eq selection previous)
|
|
maxcnt
|
|
(>= repeats maxcnt)) ; hit maximum limit, try again
|
|
(setf selection
|
|
(select-random len lis previous repeats mincnt maxcnt))
|
|
(incf iterations)
|
|
(cond ((> iterations 10000)
|
|
(error
|
|
(format nil
|
|
"~A, unable to pick next item after 10000 tries"
|
|
name)
|
|
lis))))
|
|
(t (return)))) ; break from loop, we found a selection
|
|
|
|
; otherwise, we are ok
|
|
(if (not (eq selection previous))
|
|
(setf repeats 1)
|
|
(incf repeats))
|
|
(setf mincnt (rand-item-min selection))
|
|
(setf maxcnt (rand-item-max selection))
|
|
(setf previous selection)
|
|
;(display "new selection" repeats mincnt maxcnt selection)
|
|
(send self :set-current (rand-item-value selection)))))
|
|
|
|
|
|
(defun make-random (lis &key for (name "random") trace)
|
|
(check-for-list-or-pattern lis "make-random")
|
|
(send random-class :new lis for name trace))
|
|
|
|
|
|
;; ---- PALINDROME class -----
|
|
|
|
#| Palindrome includes elide, which is either t, nil, :first, or :last.
|
|
The pattern length is the "natural" length of the pattern, which goes
|
|
forward and backward through the list. Thus, if the list is of length N,
|
|
the palindrome length depends on elide as follows:
|
|
elide length
|
|
nil 2N
|
|
t 2N - 2
|
|
:first 2N - 1
|
|
:last 2N - 1
|
|
If elide is a pattern, and if length is not specified, then length should
|
|
be computed based on elide.
|
|
|#
|
|
|
|
|
|
(setf palindrome-class (send class :new
|
|
'(lis revlis lis-pattern
|
|
direction elide-pattern
|
|
elide cursor)
|
|
'() pattern-class))
|
|
|
|
(send palindrome-class :answer :set-list '(l)
|
|
'((setf lis l)
|
|
(check-for-list lis "palindrome-class :start-period")
|
|
(setf is-nested (list-has-pattern lis))
|
|
(setf lis (make-homogeneous l))
|
|
(setf revlis (reverse lis)
|
|
direction t
|
|
cursor lis)))
|
|
|
|
|
|
(send palindrome-class :answer :isnew '(l e for nm tr)
|
|
'((cond ((patternp l)
|
|
(setf lis-pattern l))
|
|
((listp l)
|
|
(send self :set-list l))
|
|
(t
|
|
(error (format nil "~A, expected list" nm) l)))
|
|
(setf elide-pattern e length-pattern for name nm trace tr)))
|
|
|
|
|
|
(send palindrome-class :answer :start-period '()
|
|
'((cond (lis-pattern
|
|
(send self :set-list (next lis-pattern t))
|
|
(setf cursor lis)))
|
|
(setf elide (next elide-pattern))
|
|
(if (and elide (null lis))
|
|
(error (format nil "~A, cannot elide if list is empty" name)))
|
|
(if (null count)
|
|
(setf count (- (* 2 (length lis))
|
|
(if (member elide '(:first :last))
|
|
1
|
|
(if elide 2 0)))))))
|
|
|
|
|
|
(send palindrome-class :answer :next-item '()
|
|
'((send self :set-current (car cursor))
|
|
(pop cursor)
|
|
(cond ((and cursor (not (cdr cursor))
|
|
(or (and direction (member elide '(:last t)))
|
|
(and (not direction) (member elide '(:first t)))))
|
|
(pop cursor)))))
|
|
|
|
|
|
(send palindrome-class :answer :advance '()
|
|
'(
|
|
(cond (cursor
|
|
(send self :next-item))
|
|
(direction ;; we're going forward
|
|
(setf direction nil) ;; now going backward
|
|
(setf cursor revlis)
|
|
(send self :next-item))
|
|
(t ;; direction is reverse
|
|
(setf direction t)
|
|
(setf cursor lis)
|
|
(send self :next-item)))))
|
|
|
|
|
|
(defun make-palindrome (lis &key elide for (name "palindrome") trace)
|
|
(check-for-list-or-pattern lis "make-palindrome")
|
|
(send palindrome-class :new lis elide for name trace))
|
|
|
|
|
|
;; ================= HEAP CLASS ======================
|
|
|
|
;; to handle the :max keyword, which tells the object to avoid
|
|
;; repeating the last element of the previous period:
|
|
;;
|
|
;; maxcnt = 1 means "avoid the repetition"
|
|
;; check-repeat signals we are at the beginning of the period and must check
|
|
;; prev holds the previous value (initially nil)
|
|
;; after each item is generated, check-repeat is cleared. It is
|
|
;; recalculated when a new period is started.
|
|
|
|
(setf heap-class (send class :new '(lis used maxcnt prev check-repeat
|
|
lis-pattern len)
|
|
'() pattern-class))
|
|
|
|
(send heap-class :answer :isnew '(l for mx nm tr)
|
|
'((cond ((patternp l)
|
|
(setf lis-pattern l))
|
|
((listp l)
|
|
; make a copy of l to avoid side effects
|
|
(send self :set-list (append l nil)))
|
|
(t
|
|
(error (format nil "~A, expected list" nm) l)))
|
|
(setf length-pattern for maxcnt mx name nm trace tr)))
|
|
|
|
|
|
(send heap-class :answer :set-list '(l)
|
|
'((setf lis l)
|
|
(check-for-list lis "heap-class :set-list")
|
|
(setf is-nested (list-has-pattern lis))
|
|
(setf lis (make-homogeneous lis))
|
|
(setf len (length lis))))
|
|
|
|
|
|
(send heap-class :answer :start-period '()
|
|
'(;(display "heap-class :start-period" lis-pattern count lis)
|
|
(cond (lis-pattern
|
|
(send self :set-list (next lis-pattern t))))
|
|
; start of period -- may need to avoid repeating previous item
|
|
(if (= maxcnt 1) (setf check-repeat t))
|
|
(if (null count)
|
|
(setf count len))))
|
|
|
|
|
|
(defun delete-first (elem lis)
|
|
(cond ((null lis) nil)
|
|
((eq elem (car lis))
|
|
(cdr lis))
|
|
(t
|
|
(cons (car lis) (delete-first elem (cdr lis))))))
|
|
|
|
|
|
;; NO-DISTINCT-ELEM -- check if any element of list is not val
|
|
;;
|
|
(defun no-distinct-elem (lis val)
|
|
(not
|
|
(dolist (elem lis)
|
|
(if (not (equal elem val))
|
|
;; there is a distinct element, return t from dolist
|
|
(return t)))))
|
|
;; if no distinct element, dolist returns nil, but this is negated
|
|
;; by the NOT so the function will return t
|
|
|
|
|
|
(send heap-class :answer :advance '()
|
|
'((cond ((null lis)
|
|
(setf lis used)
|
|
(setf used nil)))
|
|
(let (n elem)
|
|
(cond ((and check-repeat (no-distinct-elem lis prev))
|
|
(error (format nil "~A, cannot avoid repetition, but :max is 1"
|
|
name))))
|
|
(loop
|
|
(setf n (random (length lis)))
|
|
(setf elem (nth n lis))
|
|
(if (or (not check-repeat) (not (equal prev elem)))
|
|
(return))) ;; loop until suitable element is chosen
|
|
(setf lis (delete-first elem lis))
|
|
(push elem used)
|
|
(setf check-repeat nil)
|
|
(setf prev elem)
|
|
(send self :set-current elem))))
|
|
|
|
(defun make-heap (lis &key for (max 2) (name "heap") trace)
|
|
(send heap-class :new lis for max name trace))
|
|
|
|
;;================== COPIER CLASS ====================
|
|
|
|
(setf copier-class (send class :new '(sub-pattern repeat repeat-pattern
|
|
merge merge-pattern period cursor)
|
|
'() pattern-class))
|
|
|
|
(send copier-class :answer :isnew '(p r m for nm tr)
|
|
'((setf sub-pattern p repeat-pattern r merge-pattern m)
|
|
(setf length-pattern for name nm trace tr)))
|
|
|
|
|
|
#| copier-class makes copies of periods from sub-pattern
|
|
|
|
If merge is true, the copies are merged into one big period.
|
|
If merge is false, then repeat separate periods are returned.
|
|
If repeat is negative, then -repeat periods of sub-pattern
|
|
are skipped.
|
|
|
|
merge and repeat are computed from merge-pattern and
|
|
repeat-pattern initially and after making repeat copies
|
|
|
|
To repeat individual items, set the :for keyword parameter of
|
|
the sub-pattern to 1.
|
|
|#
|
|
|
|
(send copier-class :answer :start-period '()
|
|
'((cond ((null count)
|
|
(cond ((or (null repeat) (zerop repeat))
|
|
(send self :really-start-period))
|
|
(t
|
|
(setf count (length period))))))))
|
|
|
|
|
|
(send copier-class :answer :really-start-period '()
|
|
'(;(display "copier-class :really-start-period" count)
|
|
(setf merge (next merge-pattern))
|
|
(setf repeat (next repeat-pattern))
|
|
(while (minusp repeat)
|
|
(dotimes (i (- repeat))
|
|
(setf period (next sub-pattern t)))
|
|
(setf repeat (next repeat-pattern))
|
|
(setf merge (next merge-pattern)))
|
|
(setf period (next sub-pattern t))
|
|
(setf cursor nil)
|
|
(if (null count)
|
|
(setf count (* (if merge repeat 1)
|
|
(length period))))))
|
|
|
|
|
|
(send copier-class :answer :advance '()
|
|
'((let ((loop-count 0))
|
|
(loop
|
|
;(display "copier loop" repeat cursor period)
|
|
(cond (cursor
|
|
(send self :set-current (car cursor))
|
|
(pop cursor)
|
|
(return))
|
|
((plusp repeat)
|
|
(decf repeat)
|
|
(setf cursor period))
|
|
((> loop-count 10000)
|
|
(error (format nil
|
|
"~A, copier-class :advance encountered 10000 empty periods"
|
|
name)))
|
|
(t
|
|
(send self :really-start-period)))
|
|
(incf loop-count)))))
|
|
|
|
|
|
(defun make-copier (sub-pattern &key for (repeat 1) merge (name "copier") trace)
|
|
(send copier-class :new sub-pattern repeat merge for name trace))
|
|
|
|
;; ================= ACCUMULATE-CLASS ===================
|
|
|
|
(setf accumulate-class (send class :new '(sub-pattern period cursor sum mini maxi)
|
|
'() pattern-class))
|
|
|
|
|
|
(send accumulate-class :answer :isnew '(p for nm tr mn mx)
|
|
'((setf sub-pattern p length-pattern for name nm trace tr sum 0 mini mn maxi mx)
|
|
; (display "accumulate isnew" self nm)
|
|
))
|
|
|
|
|
|
#|
|
|
accumulate-class creates sums of numbers from another pattern
|
|
The output periods are the same as the input periods (by default).
|
|
|#
|
|
|
|
(send accumulate-class :answer :start-period '()
|
|
'((cond ((null count)
|
|
(send self :really-start-period)))))
|
|
|
|
|
|
(send accumulate-class :answer :really-start-period '()
|
|
'((setf period (next sub-pattern t))
|
|
(setf cursor period)
|
|
;(display "accumulate-class :really-start-period" period cursor count)
|
|
(if (null count)
|
|
(setf count (length period)))))
|
|
|
|
|
|
(send accumulate-class :answer :advance '()
|
|
'((let ((loop-count 0) (minimum (next mini)) (maximum (next maxi)))
|
|
(loop
|
|
(cond (cursor
|
|
(setf sum (+ sum (car cursor)))
|
|
(cond ((and (numberp minimum) (< sum minimum))
|
|
(setf sum minimum)))
|
|
(cond ((and (numberp maximum) (> sum maximum))
|
|
(setf sum maximum)))
|
|
(send self :set-current sum)
|
|
(pop cursor)
|
|
(return))
|
|
((> loop-count 10000)
|
|
(error (format nil
|
|
"~A, :advance encountered 10000 empty periods" name)))
|
|
(t
|
|
(send self :really-start-period)))
|
|
(incf loop-count)))))
|
|
|
|
|
|
(defun make-accumulate (sub-pattern &key for min max (name "accumulate") trace)
|
|
(send accumulate-class :new sub-pattern for name trace min max))
|
|
|
|
;;================== ACCUMULATION CLASS ===================
|
|
|
|
;; for each item, generate all items up to and including the item, e.g.
|
|
;; (a b c) -> (a a b a b c)
|
|
|
|
(setf accumulation-class (send class :new '(lis lis-pattern outer inner len)
|
|
'() pattern-class))
|
|
|
|
(send accumulation-class :answer :isnew '(l for nm tr)
|
|
'((cond ((patternp l)
|
|
(setf lis-pattern l))
|
|
((listp l)
|
|
(send self :set-list l))
|
|
(t
|
|
(error (format nil "~A, expected list" nm) l)))
|
|
(setf length-pattern for name nm trace tr)))
|
|
|
|
(send accumulation-class :answer :set-list '(l)
|
|
'((setf lis l)
|
|
(check-for-list lis "heap-class :set-list")
|
|
(setf lis (make-homogeneous lis))
|
|
(setf inner lis)
|
|
(setf outer lis)
|
|
(setf len (length lis))))
|
|
|
|
(send accumulation-class :answer :start-period '()
|
|
'((cond (lis-pattern
|
|
(send self :set-list (next lis-pattern t))))
|
|
; start of period, length = (n^2 + n) / 2
|
|
(if (null count) (setf count (/ (+ (* len len) len) 2)))))
|
|
|
|
(send accumulation-class :answer :advance '()
|
|
;; inner traverses lis from first to outer
|
|
;; outer traverses lis
|
|
'((let ((elem (car inner)))
|
|
(cond ((eq inner outer)
|
|
(setf outer (rest outer))
|
|
(setf outer (if outer outer lis))
|
|
(setf inner lis))
|
|
(t
|
|
(setf inner (rest inner))))
|
|
(send self :set-current elem))))
|
|
|
|
(defun make-accumulation (lis &key for (name "accumulation") trace)
|
|
(send accumulation-class :new lis for name trace))
|
|
|
|
|
|
;;================== SUM CLASS =================
|
|
|
|
(setf sum-class (send class :new '(x y period cursor fn) '() pattern-class))
|
|
|
|
(send sum-class :answer :isnew '(xx yy for nm tr)
|
|
'((setf x xx y yy length-pattern for name nm trace tr fn #'+)))
|
|
|
|
#|
|
|
sum-class creates pair-wise sums of numbers from 2 streams.
|
|
The output periods are the same as the input periods of the first
|
|
pattern argument (by default).
|
|
|#
|
|
|
|
(send sum-class :answer :start-period '()
|
|
'((cond ((null count)
|
|
(send self :really-start-period)))))
|
|
|
|
(send sum-class :answer :really-start-period '()
|
|
'((setf period (next x t))
|
|
(setf cursor period)
|
|
(if (null count)
|
|
(setf count (length period)))))
|
|
|
|
(send sum-class :answer :advance '()
|
|
'((let ((loop-count 0) rslt)
|
|
(loop
|
|
(cond (cursor
|
|
(setf rslt (funcall fn (car cursor) (next y)))
|
|
(send self :set-current rslt)
|
|
(pop cursor)
|
|
(return))
|
|
((> loop-count 10000)
|
|
(error (format nil
|
|
"~A, :advance encountered 10000 empty periods" name)))
|
|
(t
|
|
(send self :really-start-period)))
|
|
(incf loop-count)))))
|
|
|
|
|
|
(defun make-sum (x y &key for (name "sum") trace)
|
|
(send sum-class :new x y for name trace))
|
|
|
|
|
|
;;================== PRODUCT CLASS =================
|
|
|
|
(setf product-class (send class :new '() '() sum-class))
|
|
|
|
(send product-class :answer :isnew '(xx yy for nm tr)
|
|
'((setf x xx y yy length-pattern for name nm trace tr fn #'*)))
|
|
|
|
(defun make-product (x y &key for (name "product") trace)
|
|
(send product-class :new x y for name trace))
|
|
|
|
|
|
;;================== EVAL CLASS =================
|
|
|
|
(setf eval-class (send class :new '(expr expr-pattern)
|
|
'() pattern-class))
|
|
|
|
(send eval-class :answer :isnew '(e for nm tr)
|
|
'((cond ((patternp e)
|
|
(setf expr-pattern e))
|
|
(t
|
|
(setf expr e)))
|
|
(setf length-pattern for name nm trace tr)))
|
|
|
|
|
|
(send eval-class :answer :start-period '()
|
|
'(;(display "cycle-class :start-period" lis-pattern lis count length-pattern)
|
|
(cond (expr-pattern
|
|
(setf expr (next expr-pattern))))))
|
|
|
|
|
|
(send eval-class :answer :advance '()
|
|
'((send self :set-current (eval expr))))
|
|
|
|
|
|
(defun make-eval (expr &key (for 1) (name "eval") trace)
|
|
(send eval-class :new expr for name trace))
|
|
|
|
;;================== MARKOV CLASS ====================
|
|
|
|
(setf markov-class (send class :new
|
|
'(rules order state produces pattern len)
|
|
'() pattern-class))
|
|
|
|
|
|
(defun is-produces-homogeneous (produces)
|
|
(let (type elem)
|
|
(setf *rslt* nil)
|
|
(loop
|
|
(cond ((or (null produces) (eq produces :eval) (null (cadr produces)))
|
|
(return t)))
|
|
(setf elem (cadr produces))
|
|
(cond ((null type)
|
|
(setf type (if (patternp elem) 'pattern 'atom))
|
|
;(display "is-produces-homogeneous" type)
|
|
(setf *rslt* (eq type 'pattern))
|
|
;(display "is-produces-homogeneous" *rslt*)
|
|
)
|
|
((and (eq type 'pattern) (not (patternp elem)))
|
|
(return nil))
|
|
((and (eq type 'atom)
|
|
(patternp elem))
|
|
(return nil)))
|
|
(setf produces (cddr produces)))))
|
|
|
|
|
|
(defun make-produces-homogeneous (produces)
|
|
(let (result item)
|
|
(loop
|
|
(if (null produces) (return nil))
|
|
(push (car produces) result)
|
|
(setf produces (cdr produces))
|
|
(setf item (car produces))
|
|
(setf produces (cdr produces))
|
|
(if (not (patternp item))
|
|
(setf item (make-cycle (list item))))
|
|
(push item result))
|
|
(reverse result)))
|
|
|
|
|
|
(send markov-class :answer :isnew '(r o s p for nm tr)
|
|
;; input parameters are rules, order, state, produces, for, name, trace
|
|
'((setf order o state s produces p length-pattern for name nm trace tr)
|
|
(setf len (length r))
|
|
;; input r looks like this:
|
|
;; ((prev1 prev2 -> next1 next2 (next3 weight) ... ) ...)
|
|
;; transition table will look like a list of these:
|
|
;; ((prev1 prev2 ... prevn) (next1 weight weight-pattern) ...)
|
|
(dolist (rule r)
|
|
(let ((targets (cdr (nthcdr order rule)))
|
|
entry pattern)
|
|
;; build entry in reverse order
|
|
(dolist (target targets)
|
|
(push (if (atom target)
|
|
(list target 1 1)
|
|
(list (first target)
|
|
(next (second target))
|
|
(second target)))
|
|
entry))
|
|
; (display "isnew" entry rule targets order (nthcdr order rule))
|
|
(dotimes (i order)
|
|
(push (nth i rule) pattern))
|
|
(push (cons (reverse pattern) entry) rules)))
|
|
(setf rules (reverse rules)) ;; keep rules in original order
|
|
(setf *rslt* nil) ;; in case produces is nil
|
|
(cond ((and produces (not (is-produces-homogeneous produces)))
|
|
(setf produces (make-produces-homogeneous produces))))
|
|
;(display "markov-class :isnew" *rslt*)
|
|
(setf is-nested *rslt*) ;; returned by is-produces-homogeneous
|
|
;(display "markov-class :isnew" is-nested)
|
|
))
|
|
|
|
|
|
(defun markov-match (state pattern)
|
|
(dolist (p pattern t) ;; return true if no mismatch
|
|
;; compare element-by-element
|
|
(cond ((eq p '*)) ; anything matches '*
|
|
((eql p (car state)))
|
|
(t (return nil))) ; a mismatch: return false
|
|
(setf state (cdr state))))
|
|
|
|
(defun markov-sum-of-weights (rule)
|
|
;(display "sum-of-weights" rule)
|
|
(let ((sum 0.0))
|
|
(dolist (target (cdr rule))
|
|
;(display "markov-sum-of-weights" target)
|
|
(setf sum (+ sum (second target))))
|
|
sum))
|
|
|
|
|
|
(defun markov-pick-target (sum rule)
|
|
(let ((total 0.0)
|
|
;; want to choose a value in the interval [0, sum)
|
|
;; but real-random is not open on the right, so fudge
|
|
;; the range by a small amount:
|
|
(r (real-random 0.0 (- sum SCORE-EPSILON))))
|
|
(dolist (target (cdr rule))
|
|
(setf total (+ total (second target)))
|
|
(cond ((> total r) (return (car target)))))))
|
|
|
|
|
|
(defun markov-update-weights (rule)
|
|
(dolist (target (cdr rule))
|
|
(setf (car (cdr target)) (next (caddr target)))))
|
|
|
|
|
|
(defun markov-map-target (target produces)
|
|
(while (and produces (not (eq target (car produces))))
|
|
(setf produces (cddr produces)))
|
|
(cadr produces))
|
|
|
|
|
|
(send markov-class :answer :find-rule '()
|
|
'((let (rslt)
|
|
;(display "find-rule" rules)
|
|
(dolist (rule rules)
|
|
;(display "find-rule" state rule)
|
|
(cond ((markov-match state (car rule))
|
|
(setf rslt rule)
|
|
(return rslt))))
|
|
(cond ((null rslt)
|
|
(display "Error, no matching rule found" state rules)
|
|
(error (format nil "~A, (markov-class)" name))))
|
|
rslt)))
|
|
|
|
|
|
(send markov-class :answer :start-period '()
|
|
'((if (null count)
|
|
(setf count len))))
|
|
|
|
(defun markov-general-rule-p (rule)
|
|
(let ((pre (car rule)))
|
|
(cond ((< (length pre) 2) nil) ;; 1st-order mm
|
|
(t
|
|
;; return false if any member not *
|
|
;; return t if all members are *
|
|
(dolist (s pre t)
|
|
(if (eq s '*) t (return nil)))))))
|
|
|
|
(defun markov-find-state-leading-to (target rules)
|
|
(let (candidates)
|
|
(dolist (rule rules)
|
|
(let ((targets (cdr rule)))
|
|
(dolist (targ targets)
|
|
(cond ((eql (car targ) target)
|
|
(push (car rule) candidates))))))
|
|
(cond (candidates ;; found at least one
|
|
(nth (random (length candidates)) candidates))
|
|
(t
|
|
nil))))
|
|
|
|
(send markov-class :answer :advance '()
|
|
'((let (rule sum target rslt new-state)
|
|
;(display "markov" pattern rules)
|
|
(setf rule (send self :find-rule))
|
|
;(display "advance 1" rule)
|
|
(markov-update-weights rule)
|
|
;(display "advance 2" rule)
|
|
(setf sum (markov-sum-of-weights rule))
|
|
;; the target can be a pattern, so apply NEXT to it
|
|
(setf target (next (markov-pick-target sum rule)))
|
|
;; if the matching rule is multiple *'s, then this
|
|
;; is a higher-order Markov model, and we may now
|
|
;; wander around in parts of the state space that
|
|
;; never appeared in the training data. To avoid this
|
|
;; we violate the strict interpretation of the rules
|
|
;; and pick a random state sequence from the rule set
|
|
;; that might have let to the current state. We jam
|
|
;; this state sequence into state so that when we
|
|
;; append target, we'll have a history that might
|
|
;; have a corresponding rule next time.
|
|
(cond ((markov-general-rule-p rule)
|
|
(setf new-state (markov-find-state-leading-to target rules))
|
|
(cond (new-state
|
|
;(display "state replacement" new-state target)
|
|
(setf state new-state)))))
|
|
(setf state (append (cdr state) (list target)))
|
|
;(display "markov next" rule sum target state)
|
|
;; target is the symbol for the current state. We can
|
|
;; return target (default), the value of target, or a
|
|
;; mapped value:
|
|
(cond ((eq produces :eval)
|
|
(setf target (eval target)))
|
|
((and produces (listp produces))
|
|
;(display "markov-produce" target produces)
|
|
(setf target (markov-map-target target produces))))
|
|
(if (not (eq is-nested (patternp target)))
|
|
(error (format nil
|
|
"~A :is-nested keyword (~A) not consistent with result (~A)"
|
|
name is-nested target)))
|
|
(send self :set-current target))))
|
|
|
|
|
|
(defun make-markov (rules &key produces past for (name "markov") trace)
|
|
;; check to make sure past and rules are consistent
|
|
(let ((order (length past)))
|
|
(dolist (rule rules)
|
|
(dotimes (i order)
|
|
(if (eq (car rule) '->)
|
|
(error (format nil "~A, a rule does not match the length of :past"
|
|
name)))
|
|
(pop rule))
|
|
(if (eq (car rule) '->) nil
|
|
(error (format nil "~A, a rule does not match the length of :past"
|
|
name)))))
|
|
(cond ((null for)
|
|
(setf for (length rules))))
|
|
(send markov-class :new rules (length past) past produces for name trace))
|
|
|
|
|
|
(defun markov-rule-match (rule state)
|
|
(cond ((null state) t)
|
|
((eql (car rule) (car state))
|
|
(markov-rule-match (cdr rule) (cdr state)))
|
|
(t nil)))
|
|
|
|
|
|
(defun markov-find-rule (rules state)
|
|
(dolist (rule rules)
|
|
;(display "find-rule" rule)
|
|
(cond ((markov-rule-match rule state)
|
|
(return rule)))))
|
|
|
|
;; ------- functions below are for MARKOV-CREATE-RULES --------
|
|
|
|
;; MARKOV-FIND-CHOICE -- given a next state, find it in rule
|
|
;;
|
|
;; use state to get the order of the Markov model, e.g. how
|
|
;; many previous states to skip in the rule, (add 1 for '->).
|
|
;; then use assoc to do a quick search
|
|
;;
|
|
;; example:
|
|
;; (markov-find-choice '(a b -> (c 1) (d 2)) '(a b) 'd)
|
|
;; returns (d 2) from the rule
|
|
;;
|
|
(defun markov-find-choice (rule state next)
|
|
(assoc next (nthcdr (1+ (length state)) rule)))
|
|
|
|
(defun markov-update-rule (rule state next)
|
|
(let ((choice (markov-find-choice rule state next)))
|
|
(cond (choice
|
|
(setf (car (cdr choice)) (1+ (cadr choice))))
|
|
(t
|
|
(nconc rule (list (list next 1)))))
|
|
rule))
|
|
|
|
|
|
(defun markov-update-rules (rules state next)
|
|
(let ((rule (markov-find-rule rules state)))
|
|
(cond (rule
|
|
(markov-update-rule rule state next))
|
|
(t
|
|
(setf rules
|
|
(nconc rules
|
|
(list (append state
|
|
(cons '-> (list
|
|
(list next 1)))))))))
|
|
rules))
|
|
|
|
|
|
;; MARKOV-UPDATE-HISTOGRAM -- keep a list of symbols and counts
|
|
;;
|
|
;; This histogram will become the right-hand part of a rule, so
|
|
;; the format is ((symbol count) (symbol count) ...)
|
|
;;
|
|
(defun markov-update-histogram (histogram next)
|
|
(let ((pair (assoc next histogram)))
|
|
(cond (pair
|
|
(setf (car (cdr pair)) (1+ (cadr pair))))
|
|
(t
|
|
(setf histogram (cons (list next 1) histogram))))
|
|
histogram))
|
|
|
|
|
|
(defun markov-create-rules (sequence order &optional generalize)
|
|
(let ((seqlen (length sequence)) state rules next histogram rule)
|
|
(cond ((<= seqlen order)
|
|
(error "markov-create-rules: sequence must be longer than order"))
|
|
((< order 1)
|
|
(error "markov-create-rules: order must be 1 or greater")))
|
|
; build initial state sequence
|
|
(dotimes (i order)
|
|
(setf state (nconc state (list (car sequence))))
|
|
(setf sequence (cdr sequence)))
|
|
; for each symbol, either update a rule or add a rule
|
|
(while sequence
|
|
(setf next (car sequence))
|
|
(setf sequence (cdr sequence))
|
|
(setf rules (markov-update-rules rules state next))
|
|
(setf histogram (markov-update-histogram histogram next))
|
|
; shift next state onto current state list
|
|
(setf state (nconc (cdr state) (list next))))
|
|
; generalize?
|
|
(cond (generalize
|
|
(setf rule (cons '-> histogram))
|
|
(dotimes (i order)
|
|
(setf rule (cons '* rule)))
|
|
(setf rules (nconc rules (list rule)))))
|
|
rules))
|
|
|
|
|
|
;; ----- WINDOW Class ---------
|
|
|
|
(setf window-class (send class :new
|
|
'(pattern skip-pattern lis cursor)
|
|
'() pattern-class))
|
|
|
|
(send window-class :answer :isnew '(p for sk nm tr)
|
|
'((setf pattern p length-pattern for skip-pattern sk name nm trace tr)))
|
|
|
|
|
|
(send window-class :answer :start-period '()
|
|
'((if (null count) (error (format nil "~A, :start-period -- count is null"
|
|
name)))
|
|
(cond ((null lis) ;; first time
|
|
(dotimes (i count)
|
|
(push (next pattern) lis))
|
|
(setf lis (reverse lis)))
|
|
(t
|
|
(let ((skip (next skip-pattern)))
|
|
(dotimes (i skip)
|
|
(if lis (pop lis) (next pattern))))
|
|
(setf lis (reverse lis))
|
|
(let ((len (length lis)))
|
|
(while (< len count)
|
|
(incf len)
|
|
(push (next pattern) lis))
|
|
(while (> len count)
|
|
(decf len)
|
|
(pop lis))
|
|
(setf lis (reverse lis)))))
|
|
(setf cursor lis)))
|
|
|
|
|
|
(send window-class :answer :advance '()
|
|
'((send self :set-current (car cursor))
|
|
(pop cursor)))
|
|
|
|
(defun make-window (pattern length-pattern skip-pattern
|
|
&key (name "window") trace)
|
|
(send window-class :new pattern length-pattern skip-pattern name trace))
|
|
|
|
;; SCORE-SORTED -- test if score is sorted
|
|
;;
|
|
(defun score-sorted (score)
|
|
(let ((result t))
|
|
(while (cdr score)
|
|
(cond ((event-before (cadr score) (car score))
|
|
(setf result nil)
|
|
(return nil)))
|
|
(setf score (cdr score)))
|
|
result))
|
|
|
|
|
|
(defmacro score-gen (&rest args)
|
|
(let (key val tim dur (name ''note) ioi trace save
|
|
score-len score-dur others pre post
|
|
next-expr (score-begin 0) score-end)
|
|
(while (and args (cdr args))
|
|
(setf key (car args))
|
|
(setf val (cadr args))
|
|
(setf args (cddr args))
|
|
(case key
|
|
(:time (setf tim val))
|
|
(:dur (setf dur val))
|
|
(:name (setf name val))
|
|
(:ioi (setf ioi val))
|
|
(:trace (setf trace val))
|
|
(:save (setf save val))
|
|
(:pre (setf pre val))
|
|
(:post (setf post val))
|
|
(:score-len (setf score-len val))
|
|
(:score-dur (setf score-dur val))
|
|
(:begin (setf score-begin val))
|
|
(:end (setf score-end val))
|
|
(t (setf others (cons key (cons val others))))))
|
|
;; make sure at least one of score-len, score-dur is present
|
|
(cond ((and (null score-len) (null score-dur))
|
|
(error
|
|
"score-gen needs either :score-len or :score-dur to limit length")))
|
|
;; compute expression for dur
|
|
(cond ((null dur)
|
|
(setf dur 'sg:ioi)))
|
|
;; compute expression for ioi
|
|
(cond ((null ioi)
|
|
(setf ioi 1)))
|
|
;; compute expression for next start time
|
|
(setf next-expr '(+ sg:start sg:ioi))
|
|
; (display "score-gen" others)
|
|
`(let (sg:seq (sg:start ,score-begin) sg:ioi
|
|
(sg:score-len ,score-len) (sg:score-dur ,score-dur)
|
|
(sg:count 0) (sg:save ,save)
|
|
(sg:begin ,score-begin) (sg:end ,score-end) sg:det-end)
|
|
;; sg:det-end is a flag that tells us to determine the end time
|
|
(cond ((null sg:end) (setf sg:end 0 sg:det-end t)))
|
|
;; make sure at least one of score-len, score-dur is present
|
|
(loop
|
|
(cond ((or (and sg:score-len (<= sg:score-len sg:count))
|
|
(and sg:score-dur (<= (+ sg:begin sg:score-dur) sg:start)))
|
|
(return)))
|
|
,pre
|
|
,(cond (tim (list 'setf 'sg:start tim)))
|
|
(setf sg:ioi ,ioi)
|
|
(setf sg:dur ,dur)
|
|
(push (list sg:start sg:dur (list ,name ,@others))
|
|
sg:seq)
|
|
,post
|
|
(cond (,trace
|
|
(format t "get-seq trace at ~A stretch ~A: ~A~%"
|
|
sg:start sg:dur (car sg:seq))))
|
|
(incf sg:count)
|
|
(setf sg:start ,next-expr)
|
|
;; end time of score will be max over start times of the next note
|
|
;; this bases the score duration on ioi's rather than durs. But
|
|
;; if user specified sg:end, sg:det-end is false and we do not
|
|
;; try to compute sg:end.
|
|
(cond ((and sg:det-end (> sg:start sg:end))
|
|
(setf sg:end sg:start))))
|
|
(setf sg:seq (reverse sg:seq))
|
|
;; avoid sorting a sorted list -- XLisp's quicksort can overflow the
|
|
;; stack if the list is sorted because (apparently) the pivot points
|
|
;; are not random.
|
|
(cond ((not (score-sorted sg:seq))
|
|
(setf sg:seq (bigsort sg:seq #'event-before))))
|
|
(push (list 0 0 (list 'SCORE-BEGIN-END ,score-begin sg:end)) sg:seq)
|
|
(cond (sg:save (set sg:save sg:seq)))
|
|
sg:seq)))
|
|
|
|
;; ============== score manipulation ===========
|
|
|
|
(defun event-before (a b)
|
|
(< (car a) (car b)))
|
|
|
|
;; EVENT-END -- get the ending time of a score event
|
|
;;
|
|
(defun event-end (e) (+ (car e) (cadr e)))
|
|
|
|
;; EVENT-TIME -- time of an event
|
|
;;
|
|
(setfn event-time car)
|
|
|
|
;; EVENT-DUR -- duration of an event
|
|
;;
|
|
(setfn event-dur cadr)
|
|
|
|
;; EVENT-SET-TIME -- new event with new time
|
|
;;
|
|
(defun event-set-time (event time)
|
|
(cons time (cdr event)))
|
|
|
|
|
|
;; EVENT-SET-DUR -- new event with new dur
|
|
;;
|
|
(defun event-set-dur (event dur)
|
|
(list (event-time event)
|
|
dur
|
|
(event-expression event)))
|
|
|
|
|
|
;; EVENT-SET-EXPRESSION -- new event with new expression
|
|
;;
|
|
(defun event-set-expression (event expression)
|
|
(list (event-time event)
|
|
(event-dur event)
|
|
expression))
|
|
|
|
;; EXPR-HAS-ATTR -- test if expression has attribute
|
|
;;
|
|
(defun expr-has-attr (expression attr)
|
|
(member attr expression))
|
|
|
|
|
|
;; EXPR-GET-ATTR -- get value of attribute from expression
|
|
;;
|
|
(defun expr-get-attr (expression attr &optional default)
|
|
(let ((m (member attr expression)))
|
|
(if m (cadr m) default)))
|
|
|
|
|
|
;; EXPR-SET-ATTR -- set value of an attribute in expression
|
|
;; (returns new expression)
|
|
(defun expr-set-attr (expr attr value)
|
|
(cons (car expr) (expr-parameters-set-attr (cdr expr) attr value)))
|
|
|
|
(defun expr-parameters-set-attr (lis attr value)
|
|
(cond ((null lis) (list attr value))
|
|
((eq (car lis) attr) (cons attr (cons value (cddr lis))))
|
|
(t (cons (car lis)
|
|
(cons (cadr lis)
|
|
(expr-parameters-set-attr (cddr lis) attr value))))))
|
|
|
|
|
|
;; EXPR-REMOVE-ATTR -- expression without attribute value pair
|
|
(defun expr-remove-attr (event attr)
|
|
(cons (car expr) (expr-parameters-remove-attr (cdr expr) attr)))
|
|
|
|
(defun expr-parameters-remove-attr (lis attr)
|
|
(cond ((null lis) nil)
|
|
((eq (car lis) attr) (cddr lis))
|
|
(t (cons (car lis)
|
|
(cons (cadr lis)
|
|
(expr-parameters-remove-attr (cddr lis) attr))))))
|
|
|
|
|
|
;; EVENT-GET-ATTR -- get value of attribute from event
|
|
;;
|
|
(defun event-get-attr (note attr &optional default)
|
|
(expr-get-attr (event-expression note) attr default))
|
|
|
|
|
|
;; EVENT-SET-ATTR -- new event with attribute = value
|
|
(defun event-set-attr (event attr value)
|
|
(event-set-expression
|
|
event
|
|
(expr-set-attr (event-expression event) attr value)))
|
|
|
|
|
|
;; EVENT-REMOVE-ATTR -- new event without atttribute value pair
|
|
(defun event-remove-attr (event attr)
|
|
(event-set-expression
|
|
event
|
|
(event-remove-attr (event-expression event) attr)))
|
|
|
|
|
|
;; SCORE-GET-BEGIN -- get the begin time of a score
|
|
;;
|
|
(defun score-get-begin (score)
|
|
(setf score (score-must-have-begin-end score))
|
|
(cadr (event-expression (car score))))
|
|
|
|
|
|
;; SCORE-SET-BEGIN -- set the begin time of a score
|
|
;;
|
|
(defun score-set-begin (score time)
|
|
(setf score (score-must-have-begin-end score))
|
|
(cons (list 0 0 (list 'score-begin-end time
|
|
(caddr (event-expression (car score)))))
|
|
(cdr score)))
|
|
|
|
|
|
;; SCORE-GET-END -- get the end time of a score
|
|
;;
|
|
(defun score-get-end (score)
|
|
(setf score (score-must-have-begin-end score))
|
|
(caddr (event-expression (car score))))
|
|
|
|
|
|
;; SCORE-SET-END -- set the end time of a score
|
|
;;
|
|
(defun score-set-end (score time)
|
|
(setf score (score-must-have-begin-end score))
|
|
(cons (list 0 0 (list 'score-begin-end
|
|
(cadr (event-expression (car score))) time))
|
|
(cdr score)))
|
|
|
|
|
|
;; FIND-FIRST-NOTE -- use keywords to find index of first selected note
|
|
;;
|
|
(defun find-first-note (score from-index from-time)
|
|
(let ((s (cdr score)))
|
|
;; offset by one because we removed element 0
|
|
(setf from-index (if from-index (max 0 (- from-index 1)) 0))
|
|
(setf from-time (if from-time
|
|
(- from-time SCORE-EPSILON)
|
|
(- SCORE-EPSILON)))
|
|
(if s (setf s (nthcdr from-index s)))
|
|
|
|
(while (and s (>= from-time (event-time (car s))))
|
|
(setf s (cdr s))
|
|
(incf from-index))
|
|
(1+ from-index)))
|
|
|
|
|
|
;; EVENT-BEFORE -- useful function for sorting scores
|
|
;;
|
|
(defun event-before (a b)
|
|
(< (car a) (car b)))
|
|
|
|
;; bigsort -- a sort routine that avoids recursion in order
|
|
;; to sort large lists without overflowing the evaluation stack
|
|
;;
|
|
;; Does not modify input list. Does not minimize cons-ing.
|
|
;;
|
|
;; Algorithm: first accumulate sorted sub-sequences into lists
|
|
;; Then merge pairs iteratively until only one big list remains
|
|
;;
|
|
(defun bigsort (lis cmp) ; sort lis using cmp function
|
|
;; if (funcall cmp a b) then a and b are in order
|
|
(prog (rslt sub pairs)
|
|
;; first, convert to sorted sublists stored on rslt
|
|
;; accumulate sublists in sub
|
|
get-next-sub
|
|
(if (null lis) (go done-1))
|
|
(setf sub (list (car lis)))
|
|
(setf lis (cdr lis))
|
|
fill-sub
|
|
;; invariant: sub is non-empty, in reverse order
|
|
(cond ((and lis (funcall cmp (car sub) (car lis)))
|
|
(setf sub (cons (car lis) sub))
|
|
(setf lis (cdr lis))
|
|
(go fill-sub)))
|
|
(setf sub (reverse sub)) ;; put sub in correct order
|
|
(setf rslt (cons sub rslt)) ;; build rslt in reverse order
|
|
(go get-next-sub)
|
|
done-1
|
|
;; invariant: rslt is list of sorted sublists
|
|
(if (cdr rslt) nil (go done-2))
|
|
;; invariant: rslt has at least one list
|
|
(setf pairs rslt)
|
|
(setf rslt nil)
|
|
merge-pairs ;; merge a pair and save on rslt
|
|
(if (car pairs) nil (go end-of-pass)) ;; loop until all pairs merged
|
|
;; invariant: pairs has at least one list
|
|
(setf list1 (car pairs)) ;; list1 is non-empty
|
|
(setf list2 (cadr pairs)) ;; list2 could be empty
|
|
(setf pairs (cddr pairs))
|
|
(cond (list2
|
|
(setf rslt (cons (list-merge list1 list2 cmp) rslt)))
|
|
(t
|
|
(setf rslt (cons list1 rslt))))
|
|
(go merge-pairs)
|
|
end-of-pass
|
|
(go done-1)
|
|
done-2
|
|
;; invariant: rslt has one sorted list!
|
|
(return (car rslt))))
|
|
|
|
(defun list-merge (list1 list2 cmp)
|
|
(prog (rslt)
|
|
merge-loop
|
|
(cond ((and list1 list2)
|
|
(cond ((funcall cmp (car list1) (car list2))
|
|
(setf rslt (cons (car list1) rslt))
|
|
(setf list1 (cdr list1)))
|
|
(t
|
|
(setf rslt (cons (car list2) rslt))
|
|
(setf list2 (cdr list2)))))
|
|
(list1
|
|
(return (nconc (reverse rslt) list1)))
|
|
(t
|
|
(return (nconc (reverse rslt) list2))))
|
|
(go merge-loop)))
|
|
|
|
|
|
;; SCORE-SORT -- sort a score into time order
|
|
;;
|
|
;; If begin-end exists, preserve it. If not, compute
|
|
;; it from the sorted score.
|
|
;;
|
|
(defun score-sort (score &optional (copy-flag t))
|
|
(let* ((score1 (score-must-have-begin-end score))
|
|
(begin-end (car score1))
|
|
;; if begin-end already existed, then it will
|
|
;; be the first of score. Otherwise, one must
|
|
;; have been generated above by score-must-have-begin-end
|
|
;; in which case we should create it again after sorting.
|
|
(needs-begin-end (not (eq begin-end (first score)))))
|
|
(setf score1 (cdr score1)) ;; don't include begin-end in sort.
|
|
(if copy-flag (setf score1 (append score1 nil)))
|
|
(setf score1 (bigsort score1 #'event-before))
|
|
(if needs-begin-end (score-must-have-begin-end score1)
|
|
(cons begin-end score1))
|
|
))
|
|
|
|
|
|
;; PUSH-SORT -- insert an event in (reverse) sorted order
|
|
;;
|
|
;; Note: Score should NOT have a score-begin-end expression
|
|
;;
|
|
(defun push-sort (event score)
|
|
(let (insert-after)
|
|
(cond ((null score) (list event))
|
|
((event-before (car score) event)
|
|
(cons event score))
|
|
(t
|
|
(setf insert-after score)
|
|
(while (and (cdr insert-after)
|
|
(event-before event (cadr insert-after)))
|
|
(setf insert-after (cdr insert-after)))
|
|
(setf (cdr insert-after) (cons event (cdr insert-after)))
|
|
score))))
|
|
|
|
|
|
(setf FOREVER 3600000000.0) ; 1 million hours
|
|
|
|
;; FIND-LAST-NOTE -- use keywords to find index beyond last selected note
|
|
;;
|
|
;; note that the :to-index keyword is the index of the last note (numbered
|
|
;; from zero), whereas this function returns the index of the last note
|
|
;; plus one, i.e. selected notes have an index *less than* this one
|
|
;;
|
|
(defun find-last-note (score to-index to-time)
|
|
;; skip past score-begin-end event
|
|
(let ((s (cdr score))
|
|
(n 1))
|
|
(setf to-index (if to-index (1+ to-index) (length score)))
|
|
(setf to-time (if to-time (- to-time SCORE-EPSILON) FOREVER))
|
|
(while (and s (< n to-index) (< (event-time (car s)) to-time))
|
|
(setf s (cdr s))
|
|
(incf n))
|
|
n))
|
|
|
|
|
|
;; SCORE-MUST-HAVE-BEGIN-END -- add score-begin-end event if necessary
|
|
;;
|
|
(defun score-must-have-begin-end (score)
|
|
(cond ((null score)
|
|
(list (list 0 0 (list 'SCORE-BEGIN-END 0 0))))
|
|
((eq (car (event-expression (car score))) 'SCORE-BEGIN-END)
|
|
score)
|
|
(t (cons (list 0 0 (list 'SCORE-BEGIN-END (event-time (car score))
|
|
(event-end (car (last score)))))
|
|
score))))
|
|
|
|
|
|
;; SCORE-SHIFT -- add offset to times of score events
|
|
;;
|
|
(defun score-shift (score offset &key from-index to-index from-time to-time)
|
|
(setf score (score-must-have-begin-end score))
|
|
(let ((i 1)
|
|
(start (find-first-note score from-index from-time))
|
|
(stop (find-last-note score to-index to-time))
|
|
(end (caddr (event-expression (car score))))
|
|
result)
|
|
(dolist (event (cdr score))
|
|
(cond ((and (<= start i) (< i stop))
|
|
(setf event (event-set-time
|
|
event (+ (event-time event) offset)))
|
|
(setf end (max end (event-end event)))))
|
|
(setf result (push-sort event result))
|
|
(incf i))
|
|
(cons (list 0 0 (list 'SCORE-BEGIN-END
|
|
(cadr (event-expression (car score)))
|
|
end))
|
|
(reverse result))))
|
|
|
|
|
|
;; TIME-STRETCH -- map a timestamp according to stretch factor
|
|
;;
|
|
(defun time-stretch (time stretch start-time stop-time)
|
|
(cond ((< time start-time) time)
|
|
((< time stop-time)
|
|
(+ start-time (* stretch (- time start-time))))
|
|
(t ; beyond stop-time
|
|
(+ (- time stop-time) ; how much beyond stop-time
|
|
start-time
|
|
(* stretch (- stop-time start-time))))))
|
|
|
|
|
|
;; EVENT-STRETCH -- apply time warp to an event
|
|
(defun event-stretch (event stretch dur-flag time-flag start-time stop-time)
|
|
(let* ((new-time (event-time event))
|
|
(new-dur (event-dur event))
|
|
(end-time (+ new-time new-dur)))
|
|
(cond (time-flag
|
|
(setf new-time (time-stretch new-time stretch
|
|
start-time stop-time))))
|
|
(cond ((and time-flag dur-flag)
|
|
;; both time and dur are stretched, so map the end time just
|
|
;; like the start time, then subtract to get new duration
|
|
(setf end-time (time-stretch end-time stretch
|
|
start-time stop-time))
|
|
(setf new-dur (- end-time new-time)))
|
|
((and dur-flag (>= new-time start-time) (< new-time stop-time))
|
|
;; stretch only duration, not time. If note starts in range
|
|
;; scale to get the new duration.
|
|
(setf new-dur (* stretch new-dur))))
|
|
(list new-time new-dur (event-expression event))))
|
|
|
|
|
|
;; SCORE-STRETCH -- stretch a region of the score
|
|
;;
|
|
(defun score-stretch (score factor &key (dur t) (time t)
|
|
from-index to-index (from-time 0) (to-time FOREVER))
|
|
(setf score (score-must-have-begin-end score))
|
|
(let ((begin-end (event-expression (car score)))
|
|
(i 1))
|
|
(if from-index
|
|
(setf from-time (max from-time
|
|
(event-time (nth from-index score)))))
|
|
(if to-index
|
|
(setf to-time (min to-time
|
|
(event-end (nth to-index score)))))
|
|
; stretch from start-time to stop-time
|
|
(cons (list 0 0 (list 'SCORE-BEGIN-END
|
|
(time-stretch (cadr begin-end) factor
|
|
from-time to-time)
|
|
(time-stretch (caddr begin-end) factor
|
|
from-time to-time)))
|
|
(mapcar #'(lambda (event)
|
|
(event-stretch event factor dur time
|
|
from-time to-time))
|
|
(cdr score)))))
|
|
|
|
|
|
;; Get the second element of params (the value field) and turn it
|
|
;; into a numeric value if possible (by looking up a global variable
|
|
;; binding). This allows scores to say C4 instead of 60.
|
|
;;
|
|
(defun get-numeric-value (params)
|
|
(let ((v (cadr params)))
|
|
(cond ((and (symbolp v) (boundp v) (numberp (symbol-value v)))
|
|
(setf v (symbol-value v))))
|
|
v))
|
|
|
|
|
|
(defun params-transpose (params keyword amount)
|
|
(cond ((null params) nil)
|
|
((eq keyword (car params))
|
|
(let ((v (get-numeric-value params)))
|
|
(cond ((numberp v)
|
|
(setf v (+ v amount))))
|
|
(cons (car params)
|
|
(cons v (cddr params)))))
|
|
(t (cons (car params)
|
|
(cons (cadr params)
|
|
(params-transpose (cddr params) keyword amount))))))
|
|
|
|
|
|
(defun score-transpose (score keyword amount &key
|
|
from-index to-index from-time to-time)
|
|
(score-apply score
|
|
#'(lambda (time dur expression)
|
|
(list time dur
|
|
(cons (car expression)
|
|
(params-transpose (cdr expression)
|
|
keyword amount))))
|
|
:from-index from-index :to-index to-index
|
|
:from-time from-time :to-time to-time))
|
|
|
|
|
|
(defun params-scale (params keyword amount)
|
|
(cond ((null params) nil)
|
|
((eq keyword (car params))
|
|
(let ((v (get-numeric-value params)))
|
|
(cond ((numberp v)
|
|
(setf v (* v amount))))
|
|
(cons (car params)
|
|
(cons v (cddr params)))))
|
|
(t (cons (car params)
|
|
(cons (cadr params)
|
|
(params-scale (cddr params) keyword amount))))))
|
|
|
|
|
|
(defun score-scale (score keyword amount &key
|
|
from-index to-index from-time to-time)
|
|
(score-apply score
|
|
#'(lambda (time dur expression)
|
|
(list time dur
|
|
(cons (car expression)
|
|
(params-scale (cdr expression)
|
|
keyword amount))))
|
|
:from-index from-index :to-index to-index
|
|
:from-time from-time :to-time to-time))
|
|
|
|
|
|
(defun score-sustain (score factor &key
|
|
from-index to-index from-time to-time)
|
|
(setf score (score-must-have-begin-end score))
|
|
(let ((i 0)
|
|
(start (find-first-note score from-index from-time))
|
|
(stop (find-last-note score to-index to-time))
|
|
result)
|
|
(dolist (event score)
|
|
(cond ((and (<= start i) (< i stop))
|
|
(setf event (event-set-dur
|
|
event (* (event-dur event) factor)))))
|
|
(push event result)
|
|
(incf i))
|
|
(reverse result)))
|
|
|
|
|
|
(defun map-voice (expression replacement-list)
|
|
(let ((mapping (assoc (car expression) replacement-list)))
|
|
(cond (mapping (cons (second mapping)
|
|
(cdr expression)))
|
|
(t expression))))
|
|
|
|
|
|
(defun score-voice (score replacement-list &key
|
|
from-index to-index from-time to-time)
|
|
(setf score (score-must-have-begin-end score))
|
|
(let ((i 0)
|
|
(start (find-first-note score from-index from-time))
|
|
(stop (find-last-note score to-index to-time))
|
|
result)
|
|
(dolist (event score)
|
|
(cond ((and (<= start i) (< i stop))
|
|
(setf event (event-set-expression
|
|
event (map-voice (event-expression event)
|
|
replacement-list)))))
|
|
(push event result)
|
|
(incf i))
|
|
(reverse result)))
|
|
|
|
|
|
(defun score-merge (&rest scores)
|
|
;; scores is a list of scores
|
|
(cond ((null scores) nil)
|
|
(t
|
|
(score-merge-1 (car scores) (cdr scores)))))
|
|
|
|
|
|
;; SCORE-MERGE-1 -- merge list of scores into score
|
|
;;
|
|
(defun score-merge-1 (score scores)
|
|
;; scores is a list of scores to merge
|
|
(cond ((null scores) score)
|
|
(t (score-merge-1 (score-merge-2 score (car scores))
|
|
(cdr scores)))))
|
|
|
|
;; SCORE-MERGE-2 -- merge 2 scores
|
|
;;
|
|
(defun score-merge-2 (score addin)
|
|
;(display "score-merge-2 before" score addin)
|
|
(setf score (score-must-have-begin-end score))
|
|
(setf addin (score-must-have-begin-end addin))
|
|
;(display "score-merge-2" score addin)
|
|
(let (start1 start2 end1 end2)
|
|
(setf start1 (score-get-begin score))
|
|
(setf start2 (score-get-begin addin))
|
|
(setf end1 (score-get-end score))
|
|
(setf end2 (score-get-end addin))
|
|
|
|
;; note: score-sort is destructive, but append copies score
|
|
;; and score-shift copies addin
|
|
(score-sort
|
|
(cons (list 0 0 (list 'SCORE-BEGIN-END (min start1 start2)
|
|
(max end1 end2)))
|
|
(append (cdr score) (cdr addin) nil)))))
|
|
|
|
|
|
|
|
;; SCORE-APPEND -- append scores together in sequence
|
|
;;
|
|
(defun score-append (&rest scores)
|
|
;; scores is a list of scores
|
|
(cond ((null scores) nil)
|
|
(t
|
|
(score-append-1 (car scores) (cdr scores)))))
|
|
|
|
|
|
;; SCORE-APPEND-1 -- append list of scores into score
|
|
;;
|
|
(defun score-append-1 (score scores)
|
|
;; scores is a list of scores to append
|
|
(cond ((null scores) score)
|
|
(t (score-append-1 (score-append-2 score (car scores))
|
|
(cdr scores)))))
|
|
|
|
|
|
;; SCORE-APPEND-2 -- append 2 scores
|
|
;;
|
|
(defun score-append-2 (score addin)
|
|
;(display "score-append-2" score addin)
|
|
(setf score (score-must-have-begin-end score))
|
|
(setf addin (score-must-have-begin-end addin))
|
|
(let (end1 start2 begin-end1 begin-end2)
|
|
(setf start1 (score-get-begin score))
|
|
(setf end1 (score-get-end score))
|
|
(setf start2 (score-get-begin addin))
|
|
(setf end2 (score-get-end addin))
|
|
(setf begin-end1 (event-expression (car score)))
|
|
(setf begin-end2 (event-expression (car addin)))
|
|
(setf addin (score-shift addin (- end1 start2)))
|
|
;; note: score-sort is destructive, but append copies score
|
|
;; and score-shift copies addin
|
|
(score-sort
|
|
(cons (list 0 0 (list 'SCORE-BEGIN-END start1 (+ end1 (- end2 start2))))
|
|
(append (cdr score) (cdr addin) nil)))))
|
|
|
|
|
|
(defun score-select (score predicate &key
|
|
from-index to-index from-time to-time reject)
|
|
(setf score (score-must-have-begin-end score))
|
|
(let ((begin-end (car score))
|
|
(i 1)
|
|
(start (find-first-note score from-index from-time))
|
|
(stop (find-last-note score to-index to-time))
|
|
result)
|
|
;; selected if start <= i AND i < stop AND predicate(...)
|
|
;; choose if not reject and selected or reject and not selected
|
|
;; so in other words choose if reject != selected. Use NULL to
|
|
;; coerce into boolean values and then use NOT EQ to compare
|
|
(dolist (event (cdr score))
|
|
(cond ((not (eq (null reject)
|
|
(null (and (<= start i) (< i stop)
|
|
(or (eq predicate t)
|
|
(funcall predicate
|
|
(event-time event)
|
|
(event-dur event)
|
|
(event-expression event)))))))
|
|
(push event result)))
|
|
(incf i))
|
|
(cons begin-end (reverse result))))
|
|
|
|
|
|
;; SCORE-FILTER-LENGTH -- remove notes beyond cutoff time
|
|
;;
|
|
(defun score-filter-length (score cutoff)
|
|
(let (result)
|
|
(dolist (event score)
|
|
(cond ((<= (event-end event) cutoff)
|
|
(push event result))))
|
|
(reverse result)))
|
|
|
|
|
|
;; SCORE-REPEAT -- make n copies of score in sequence
|
|
;;
|
|
(defun score-repeat (score n)
|
|
(let (result)
|
|
(dotimes (i n)
|
|
(setf result (score-append result score)))
|
|
result))
|
|
|
|
|
|
;; SCORE-STRETCH-TO-LENGTH -- stretch score to have given length
|
|
;;
|
|
(defun score-stretch-to-length (score length)
|
|
(let ((begin-time (score-get-begin score))
|
|
(end-time (score-get-end score))
|
|
duration stretch)
|
|
(setf duration (- end-time begin-time))
|
|
(cond ((< 0 duration)
|
|
(setf stretch (/ length (- end-time begin-time)))
|
|
(score-stretch score stretch))
|
|
(t score))))
|
|
|
|
|
|
(defun score-filter-overlap (score)
|
|
(setf score (score-must-have-begin-end score))
|
|
(prog (event end-time filtered-score
|
|
(begin-end (car score)))
|
|
(setf score (cdr score))
|
|
(cond ((null score) (return (list begin-end))))
|
|
loop
|
|
;; get event from score
|
|
(setf event (car score))
|
|
;; add a note to filtered-score
|
|
(push event filtered-score)
|
|
;; save the end-time of this event: start + duration
|
|
(setf end-time (+ (car event) (cadr event)))
|
|
;; now skip everything until end-time in score
|
|
loop2
|
|
(pop score) ;; move to next event in score
|
|
(cond ((null score)
|
|
(return (cons begin-end (reverse filtered-score)))))
|
|
(setf event (car score)) ;; examine next event
|
|
(setf start-time (car event))
|
|
;(display "overlap" start-time (- end-time SCORE-EPSILON))
|
|
(cond ((< start-time (- end-time SCORE-EPSILON))
|
|
;(display "toss" event start-time end-time)
|
|
(go loop2)))
|
|
(go loop)))
|
|
|
|
|
|
(defun score-print (score)
|
|
(format t "(")
|
|
(dolist (event score)
|
|
(format t "~S~%" event))
|
|
(format t ")~%"))
|
|
|
|
(defun score-play (score)
|
|
(play (timed-seq score)))
|
|
|
|
|
|
(defun score-adjacent-events (score function &key
|
|
from-index to-index from-time to-time)
|
|
(setf score (score-must-have-begin-end score))
|
|
(let ((begin-end (car score))
|
|
(a nil)
|
|
(b (second score))
|
|
(c-list (cddr score))
|
|
r newscore
|
|
(i 1)
|
|
(start (find-first-note score from-index from-time))
|
|
(stop (find-last-note score to-index to-time)))
|
|
(dolist (event (cdr score))
|
|
(setf r b)
|
|
(cond ((and (<= start i) (< i stop))
|
|
(setf r (funcall function a b (car c-list)))))
|
|
(cond (r
|
|
(push r newscore)
|
|
(setf a r)))
|
|
(setf b (car c-list))
|
|
(setf c-list (cdr c-list))
|
|
(incf i))
|
|
(score-sort (cons begin-end newscore))))
|
|
|
|
|
|
(defun score-apply (score fn &key
|
|
from-index to-index from-time to-time)
|
|
|
|
(setf score (score-must-have-begin-end score))
|
|
(let ((begin-end (car score))
|
|
(i 1)
|
|
(start (find-first-note score from-index from-time))
|
|
(stop (find-last-note score to-index to-time))
|
|
result)
|
|
(dolist (event (cdr score))
|
|
(push
|
|
(cond ((and (<= start i) (< i stop))
|
|
(funcall fn (event-time event)
|
|
(event-dur event) (event-expression event)))
|
|
(t event))
|
|
result)
|
|
(incf i))
|
|
(score-sort (cons begin-end result))))
|
|
|
|
|
|
(defun score-indexof (score fn &key
|
|
from-index to-index from-time to-time)
|
|
(setf score (score-must-have-begin-end score))
|
|
(let ((i 1)
|
|
(start (find-first-note score from-index from-time))
|
|
(stop (find-last-note score to-index to-time))
|
|
result)
|
|
(dolist (event (cdr score))
|
|
(cond ((and (<= start i) (< i stop)
|
|
(funcall fn (event-time event)
|
|
(event-dur event)
|
|
(event-expression event)))
|
|
(setf result i)
|
|
(return)))
|
|
(incf i))
|
|
result))
|
|
|
|
|
|
(defun score-last-indexof (score fn &key
|
|
from-index to-index from-time to-time)
|
|
(setf score (score-must-have-begin-end score))
|
|
(let ((i 1)
|
|
(start (find-first-note score from-index from-time))
|
|
(stop (find-last-note score to-index to-time))
|
|
result)
|
|
(dolist (event (cdr score))
|
|
(cond ((and (<= start i) (< i stop)
|
|
(funcall fn (event-time event)
|
|
(event-dur event)
|
|
(event-expression event)))
|
|
(setf result i)))
|
|
(incf i))
|
|
result))
|
|
|
|
|
|
;; SCORE-RANDOMIZE-START -- alter start times with offset
|
|
;; keywords: jitter, offset, feel factor
|
|
;;
|
|
(defun score-randomize-start (score amt &key
|
|
from-index to-index from-time to-time)
|
|
(score-apply score
|
|
(lambda (time dur expr)
|
|
(setf time (+ (real-random (- amt) amt) time))
|
|
(setf time (max 0.0 time))
|
|
(list time dur expr))))
|
|
|
|
|
|
;; SCORE-READ-SMF -- read a standard MIDI file to a score
|
|
;;
|
|
(defun score-read-smf (filename)
|
|
(let ((seq (seq-create))
|
|
(file (open-binary filename)))
|
|
(cond (file
|
|
(seq-read-smf seq file)
|
|
(close file)
|
|
(score-from-seq seq))
|
|
(t nil))))
|
|
|
|
|
|
;; SCORE-READ -- read a standard MIDI file to a score
|
|
;;
|
|
(defun score-read (filename)
|
|
(let ((seq (seq-create))
|
|
(file (open filename)))
|
|
(cond (file
|
|
(seq-read seq file)
|
|
(close file)
|
|
(score-from-seq seq))
|
|
(t nil))))
|
|
|
|
|
|
;; SET-PROGRAM-TO -- a helper function to set a list value
|
|
(defun set-program-to (lis index value default)
|
|
;; if length or lis <= index, extend the lis with default
|
|
(while (<= (length lis) index)
|
|
(setf lis (nconc lis (list default))))
|
|
;; set the nth element
|
|
(setf (nth index lis) value)
|
|
;; return the list
|
|
lis)
|
|
|
|
|
|
(defun score-from-seq (seq)
|
|
(prog (event tag score programs)
|
|
(seq-reset seq)
|
|
loop
|
|
(setf event (seq-get seq))
|
|
(setf tag (seq-tag event))
|
|
(cond ((= tag seq-done-tag)
|
|
(go exit))
|
|
((= tag seq-prgm-tag)
|
|
(let ((chan (seq-channel event))
|
|
(when (seq-time event))
|
|
(program (seq-program event)))
|
|
(setf programs (set-program-to programs chan program 0))
|
|
(push (list (* when 0.001) 1
|
|
(list 'NOTE :pitch nil :program program))
|
|
score)))
|
|
((= tag seq-note-tag)
|
|
(let ((chan (seq-channel event))
|
|
(pitch (seq-pitch event))
|
|
(vel (seq-velocity event))
|
|
(when (seq-time event))
|
|
(dur (seq-duration event)))
|
|
(push (list (* when 0.001) (* dur 0.001)
|
|
(list 'NOTE :chan (1- chan) :pitch pitch :vel vel))
|
|
score))))
|
|
(seq-next seq)
|
|
(go loop)
|
|
exit
|
|
(setf *rslt* programs) ;; extra return value
|
|
(return (score-sort score))))
|
|
|
|
|
|
(defun score-write (score filename &optional programs)
|
|
(score-write-smf score filename programs t))
|
|
|
|
(defun score-write-smf (score filename &optional programs as-adagio)
|
|
(let ((file (if as-adagio (open filename :direction :output)
|
|
(open-binary filename :direction :output)))
|
|
(seq (seq-create))
|
|
(chan 1))
|
|
(cond (file
|
|
(dolist (program programs)
|
|
;; 6 = SEQ_PROGRAM
|
|
(seq-insert-ctrl seq 0 0 6 chan program)
|
|
;(display "insert ctrl" seq 0 0 6 chan program)
|
|
(incf chan))
|
|
|
|
(dolist (event (cdr (score-must-have-begin-end score)))
|
|
(let ((time (event-time event))
|
|
(dur (event-dur event))
|
|
(chan (event-get-attr event :chan 0))
|
|
(pitch (event-get-attr event :pitch))
|
|
(program (event-get-attr event :program))
|
|
(vel (event-get-attr event :vel 100)))
|
|
(cond (program
|
|
;(display "score-write-smf program" chan program)
|
|
(seq-insert-ctrl seq (round (* time 1000))
|
|
0 6 (1+ chan)
|
|
(round program))))
|
|
(cond ((consp pitch)
|
|
(dolist (p pitch)
|
|
(seq-insert-note seq (round (* time 1000))
|
|
0 (1+ chan) (round p)
|
|
(round (* dur 1000)) (round vel))))
|
|
(pitch
|
|
(seq-insert-note seq (round (* time 1000))
|
|
0 (1+ chan) (round pitch)
|
|
(round (* dur 1000)) (round vel))))))
|
|
(if as-adagio (seq-write seq file) (seq-write-smf seq file))
|
|
(close file)))))
|
|
|
|
|
|
;; make a default note function for scores
|
|
;;
|
|
(defun note (&key (pitch 60) (vel 100))
|
|
;; load the piano if it is not loaded already
|
|
(if (not (boundp '*piano-srate*))
|
|
(abs-env (load "pianosyn")))
|
|
(piano-note-2 pitch vel))
|
|
|
|
;;================================================================
|
|
|
|
;; WORKSPACE functions have moved to envelopes.lsp
|
|
|
|
|
|
;; DESCRIBE -- add a description to a global variable
|
|
;;
|
|
(defun describe (symbol &optional description)
|
|
(add-to-workspace symbol)
|
|
(cond (description
|
|
(putprop symbol description 'description))
|
|
(t
|
|
(get symbol 'description))))
|
|
|
|
;; INTERPOLATE -- linear interpolation function
|
|
;;
|
|
;; compute y given x by interpolating between points (x1, y1) and (x2, y2)
|
|
(defun interpolate (x x1 y1 x2 y2)
|
|
(cond ((= x1 x2) x1)
|
|
(t (+ y1 (* (- x x1) (/ (- y2 y1) (- x2 (float x1))))))))
|
|
|
|
|
|
;; INTERSECTION -- set intersection
|
|
;;
|
|
;; compute the intersection of two lists
|
|
(defun intersection (a b)
|
|
(let (result)
|
|
(dolist (elem a)
|
|
(if (member elem b) (push elem result)))
|
|
result))
|
|
|
|
;; UNION -- set union
|
|
;;
|
|
;; compute the union of two lists
|
|
(defun union (a b)
|
|
(let (result)
|
|
(dolist (elem a)
|
|
(if (not (member elem result)) (push elem result)))
|
|
(dolist (elem b)
|
|
(if (not (member elem result)) (push elem result)))
|
|
result))
|
|
|
|
;; SET-DIFFERENCE -- set difference
|
|
;;
|
|
;; compute the set difference between two sets
|
|
(defun set-difference (a b)
|
|
(remove-if (lambda (elem) (member elem b)) a))
|
|
|
|
;; SUBSETP -- test is list is subset
|
|
;;
|
|
;; test if a is subset of b
|
|
(defun subsetp (a b)
|
|
(let ((result t))
|
|
(dolist (elem a)
|
|
(cond ((not (member elem b))
|
|
(setf result nil)
|
|
(return nil))))
|
|
result))
|
|
|
|
;; functions to support score editing in jNyqIDE
|
|
|
|
(if (not (boundp '*default-score-file*))
|
|
(setf *default-score-file* "score.dat"))
|
|
|
|
;; SCORE-EDIT -- save a score for editing by jNyqIDE
|
|
;;
|
|
;; file goes to a data file to be read by jNyqIDE
|
|
;; Note that the parameter is a global variable name, not a score,
|
|
;; but you do not quote the global variable name, e.g. call
|
|
;; (score-edit my-score)
|
|
;;
|
|
(defmacro score-edit (score-name)
|
|
`(score-edit-symbol (quote ,score-name)))
|
|
|
|
(defun score-edit-symbol (score-name)
|
|
(prog ((f (open *default-score-file* :direction :output))
|
|
score expr)
|
|
(cond ((symbolp score-name)
|
|
(setf score (eval score-name)))
|
|
(t
|
|
(error "score-edit expects a symbol naming the score to edit")))
|
|
(cond ((null f)
|
|
(format t "score-edit: error in output file ~A!~%" *default-score-file*)
|
|
(return nil)))
|
|
|
|
(format t "score-edit: writing ~A ...~%" *default-score-file*)
|
|
(format f "~A~%" score-name) ; put name on first line
|
|
(dolist (event score) ;cdr scor
|
|
(format f "~A " (event-time event)) ; print start time
|
|
(format f "~A " (event-dur event)) ; print duration
|
|
|
|
(setf expr (event-expression event))
|
|
|
|
; print the pitch and the rest of the attributes
|
|
(format f "~A " (expr-get-attr expr :pitch))
|
|
(format f "~A~%" (expr-parameters-remove-attr expr :pitch)))
|
|
(close f)
|
|
(format t "score-edit: wrote ~A events~%" (length score))))
|
|
|
|
|
|
;; Read in a data file stored in the score-edit format and save
|
|
;; it to the global variable it came from
|
|
(defun score-restore ()
|
|
(prog ((inf (open *default-score-file*))
|
|
name start dur pitch expr score)
|
|
(cond ((null inf)
|
|
(format t "score-restore: could not open ~A~%" *default-score-file*)
|
|
(return nil)))
|
|
(setf name (read inf)) ;; score name
|
|
(loop
|
|
(setf start (read inf))
|
|
(cond ((null start) (return)))
|
|
(setf dur (read inf))
|
|
(setf pitch (read inf))
|
|
(setf expr (read inf))
|
|
(cond (pitch
|
|
(setf expr (expr-set-attr expr :pitch pitch)))))
|
|
(close inf)
|
|
(setf (symbol-value name) score)))
|