2768 lines
98 KiB
Common Lisp
2768 lines
98 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 select a random pattern and get an item from it. The
|
|
next time you handle :next, you get another item from the same pattern
|
|
until the pattern returns +eonp+, which you can read as "end of nested
|
|
pattern". Random would then advance to the next random pattern and get
|
|
an item from it.
|
|
|
|
While generating from a nested pattern, you might return many periods
|
|
including +eop+, but you do not advance to the next pattern at any
|
|
given level until that level receives +eonp+ from the next level down.
|
|
|
|
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.
|
|
|
|
PATTERN LENGTH
|
|
|
|
There are two sorts of cycles and lengths. The nominal pattern
|
|
behavior, illustrated by cycle patterns, is to cycle through a
|
|
list. There is a "natural" length computed by :start-period and stored
|
|
in count that keeps track of this.
|
|
|
|
The second cycle and length is established by the :for parameter,
|
|
which is optional. If a number or pattern is provided, it controls the
|
|
period length and overrides any default periods. When :for is given,
|
|
count is set and used as a counter to count the items remaining in
|
|
a period.
|
|
|
|
To summarize, there are 3 ways to determine lengths:
|
|
|
|
1) The length is implicit. The length can be computed by :start-period
|
|
and turned into an explicit length stored in count.
|
|
|
|
2) The length is explicitly set with :for. This overrides the implicit
|
|
length. The explicit length is stored as count 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
|
|
in :start-period to generate an explicit length.
|
|
|
|
In case (1), a pattern object does not return +eonp+ to the next level
|
|
up unless it receives an +eonp+ from one level down *and* is at the
|
|
end of its period. E.g. in the random pattern, if there are three
|
|
nested patterns, random must see +eonp+ three times and make three
|
|
random pattern selections before returning +eonp+ to the next level
|
|
up. This is the basic mechanism for achieving a "depth-first"
|
|
expansion of patterns.
|
|
|
|
However, there is still the question of periods. When a nested pattern
|
|
returns a period, do the containing pattern return that period or
|
|
merge the period with other periods from other nested patterns? The
|
|
default is to return periods as they are generated by sub-patterns. In
|
|
other words, when a nested pattern returns +eop+ (end of period), that
|
|
token is returned by the :next message. Thus, in one "natural" cycle
|
|
of a pattern of patterns, there can be many periods (+eop+'s) before
|
|
+eonp+ is returned, marking the end of the "natural" pattern at this
|
|
level.
|
|
|
|
The alternative strategy, which is to filter out all the +eop+'s and
|
|
form one giant pattern that runs up to the natural length (+eonp+) for
|
|
this level, can be selected by setting the :merge parameter to true.
|
|
Note that :merge is ignored if :for is specified because :for says
|
|
exactly how many items are in each period.
|
|
|
|
The Copier pattern is an interesting case. It's :start-pattern should
|
|
get the next period from its sub-pattern, a repeat count from the
|
|
:repeat pattern, and a boolean from the :merge pattern. Then, it
|
|
should make that many copies, returning them as multiple periods or as
|
|
one merged one, depending on :merge, followed by +eonp+, after which
|
|
:start-pattern is called and the process repeats. But if :for 10 is
|
|
provided, this means we need to return a single period of 10 items. We
|
|
call :start-pattern, then repeat the sub-pattern's period until we
|
|
have 10 items. Thus, we ignore the :merge flag and :repeat count.
|
|
This makes Copier with a :for parameter equivalent to Cycle with a
|
|
single sub-pattern in a list. If you think :for should not override
|
|
these parameters (:repeat and :merge), you can probably get what you
|
|
want by using a Length pattern to regroup the output of a Copier.
|
|
|
|
IMPLEMENTATION
|
|
|
|
Most pattern behavior is implemented in a few inherited methods.
|
|
|
|
:next gets the next item or period. If there is a length-pattern
|
|
(from :for), :next groups items into periods, filtering out +eop+ and
|
|
+eonp+. If there is no length-pattern, :next passes +eop+ through and
|
|
watches for +eonp+ to cause the pattern to re-evaluate pattern
|
|
parameters.
|
|
|
|
Several methods are implemented by subclasses of pattern-class:
|
|
|
|
:START-PERIOD is called before the first advance and before the first
|
|
item of a period controlled by :for. It sets count to the "natural"
|
|
length of the period. HAVE-CURRENT will be set to false.
|
|
|
|
:ADVANCE advances to the next item in the pattern. If there are nested
|
|
patterns, advance is called to select the first nested pattern, then
|
|
items are returned until +eonp+ is seen, then we advance to the next
|
|
pattern, etc. After :ADVANCE, HAVE-CURRENT is true.
|
|
|
|
CURRENT is set by advance to the current item. If this has nested
|
|
patterns, current is set to a pattern, and the pattern stays there in
|
|
current until advance is called, either at the end of period or when
|
|
+eonp+ is seen.
|
|
|
|
HAVE-CURRENT is a boolean to tell when CURRENT is valid.
|
|
|
|
IS-NESTED - set when there are nested patterns. If there are, 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).
|
|
|
|
Patterns may be shared, so the state machines may be advanced by more
|
|
than one less-deeply nested pattern. Thus, patterns are really DAGs
|
|
and not trees. Since patterns are hard enough to understand, the
|
|
precise order of evaluation and therefore the behavior of shared
|
|
patterns in DAGs may not be well-defined. In this implementation
|
|
though, we only call on state machines to advance as needed (we try
|
|
not to read out whole periods).
|
|
|
|
The next() function gets an item or period by calling :next.
|
|
|
|
The :next method is shared by all pattern sub-classes and behaves
|
|
differently with :for vs. no :for parameter. With the :for parameter,
|
|
we just get items until the count is reached, but getting items is
|
|
a bit tricky, because the normal behavior (without :for) might reach
|
|
the end of the "natural" period (+eonp+) before count is
|
|
reached. So somehow, we need to override count. We could just set
|
|
count the count, but count is going to count items and due to
|
|
empty periods, count could go to zero before count does. We could
|
|
set count = 1000 * count with the idea that we're probably in an
|
|
infinite loop generating empty periods forever if count ever reaches
|
|
zero.
|
|
|
|
But then what about the Heap pattern? If count is greater than the
|
|
heap size, what happens when the heap is empty? Or should Heap not
|
|
allow :for? There are other "problem" patterns, and not all Vers. 1
|
|
patterns allowed :for, so let's make list of patterns that could use
|
|
:for:
|
|
|
|
:for is OK :for is not OK
|
|
---------- --------------
|
|
cycle heap
|
|
line accumulation
|
|
random copier
|
|
palindrome length
|
|
accumulate window
|
|
sum
|
|
product
|
|
eval
|
|
markov
|
|
|
|
It seems that we could use :for for all patterns and just extend the
|
|
behavior a bit, e.g. when the heap runs out, replenish it (without
|
|
getting another period from a sub-pattern, if any; accumulation could
|
|
just start over; copier could cycle as described earlier; length
|
|
really should not allow :for, and window could just generate :for
|
|
items before reevaluating :skip and :pattern-length parameters.
|
|
|
|
To implement this, the subclass patterns need :advance to do the right
|
|
next thing even if we are beyond the "natural" period. :advance should
|
|
go to the next sub-pattern or item without returning +eop+ or getting
|
|
the next item from any sub-pattern.
|
|
|
|
state transitions are based on count and something like this:
|
|
count
|
|
nil -> actions: :start-period, don't return, set count
|
|
N -> N-1, actions: :advance if not have-current, return next item
|
|
0 -> -1, actions: return +eop+
|
|
-1 -> nil, actions: return +eonp+
|
|
|
|
|
|
def :next()
|
|
if length-pattern: // the :for parameter value
|
|
if null(count): // initial state before every period
|
|
var forcount = next(length-pattern) // must be a number
|
|
// compute forcount first and pass to start-period in case there
|
|
// is no "natural" period length. If there is a "natural" period,
|
|
// the forcount parameter is ignored (the usual case)
|
|
self.:start-period(forcount)
|
|
have-current = false
|
|
// :start-period() sets count, but we replace it with :for parameter
|
|
count = forcount
|
|
if count == 0:
|
|
count = -1
|
|
return +eop+
|
|
if count == -1:
|
|
count = nil
|
|
return +eonp+
|
|
while true
|
|
// otherwise, here is where we return N items
|
|
if not have-current
|
|
self.:advance()
|
|
if not is-nested
|
|
// now current is updated
|
|
have-current = false
|
|
count = count - 1
|
|
return current
|
|
// nested, so get item from sub-pattern
|
|
rslt = current.:next
|
|
if rslt == +eonp+
|
|
// time to advance because sub-pattern has played out
|
|
have-current = false
|
|
elif rslt == +eop+
|
|
nil // skip ends of periods, we're merging them
|
|
// we got a real item to return
|
|
else
|
|
count = count - 1
|
|
return rslt
|
|
// here, we have no length-pattern, so use "natural" periods
|
|
// count is null, and we use count
|
|
while true
|
|
if null(count):
|
|
have-current = false
|
|
self.:start-period()
|
|
if is-nested:
|
|
if count == 0:
|
|
if merge-flag: // we filtered out +eop+ so return one here
|
|
count == -1
|
|
return +eop+
|
|
else
|
|
count = nil
|
|
return +eonp+
|
|
if count == -1
|
|
count = nil
|
|
return +eonp+
|
|
else
|
|
if count = 0:
|
|
count = -1
|
|
return +eop+
|
|
if count == -1:
|
|
count = nil
|
|
return +eonp+
|
|
// count is a number > 0
|
|
if not have-current:
|
|
self.:advance
|
|
have-current = true
|
|
if not is-nested
|
|
have-current = false
|
|
count = count - 1
|
|
return current
|
|
// nested, so get sub-pattern's next item or +eonp+ or +eop+
|
|
rslt = current.:next
|
|
if rslt == +eonp+
|
|
have-current = false // force advance next time, don't
|
|
// return +eonp+ until count == 0
|
|
else if rslt == +eop+ and merge-flag:
|
|
nil // iterate, skipping this +eop+ to merge periods
|
|
else
|
|
return rslt // either +eop+ or a real item
|
|
|
|
|
|
If the input is a list of patterns, then the pattern selects patterns
|
|
from the list, and the internal state advances as each selected
|
|
pattern completes a period. In this case, there is no way to control
|
|
the number of elements drawn from each selected pattern -- the number
|
|
is always the length of the period returned by the selected
|
|
pattern. If :for is specified, this controls the length of the period
|
|
delivered to the next less deeply nested pattern, but the delivered
|
|
period may be a mix of elements from the more deeply nested patterns.
|
|
|#
|
|
|
|
(setf SCORE-EPSILON 0.000001)
|
|
|
|
(setf pattern-class
|
|
(send class :new '(current have-current is-nested name count merge-flag
|
|
merge-pattern length-pattern trace)))
|
|
|
|
;; sub-classes should all call (send-super :isnew length-pattern name trace)
|
|
;;
|
|
(send pattern-class :answer :isnew '(mp lp nm tr)
|
|
'((setf merge-pattern mp length-pattern lp name nm trace tr)
|
|
(xm-traceif "pattern-class :isnew nm" nm "name" name)))
|
|
|
|
(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 traceflag)
|
|
(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) :trace traceflag)))
|
|
lis))))
|
|
|
|
|
|
;; used for both "advanced to" and ":next returns" messages
|
|
;;
|
|
(send pattern-class :answer :write-trace '(verb value)
|
|
'((format t "pattern ~A ~A ~A~%"
|
|
(if name name "<no-name>")
|
|
verb
|
|
(if (patternp value)
|
|
(if (send value :name)
|
|
(send value :name)
|
|
"<a-pattern>")
|
|
value))))
|
|
|
|
|
|
;; :next returns the next value, including +eop+ and +eonp+ markers
|
|
;;
|
|
(send pattern-class :answer :next '()
|
|
'((xm-traceif ":next of" name "is-nested" is-nested "length-pattern" length-pattern)
|
|
(incf xm-next-nesting)
|
|
(let ((rslt
|
|
(cond (length-pattern (send self :next-for))
|
|
(t (send self :next-natural)))))
|
|
(if trace (send self :write-trace ":next returns" rslt))
|
|
(xm-traceif-return ":next" self rslt))))
|
|
|
|
|
|
;; :next-for returns the next value, including +eop+ and +eonp+ markers
|
|
;; this code handles the cases where :for is specified, so the length
|
|
;; of each period is explicitly given, non intrinsic to the pattern
|
|
;;
|
|
(send pattern-class :answer :next-for '()
|
|
'((block pattern:next-for-block ;; so we can return from inside while loop
|
|
(cond ((null count)
|
|
(let ((forcount (next length-pattern)))
|
|
;; in the case of window-class, there is no "natural" length
|
|
;; so for that case, we pass in forcount
|
|
(send self :start-period forcount) ;; :start-period sets count,
|
|
(setf count forcount) ;; but it is replaced here by a number
|
|
(setf have-current nil))))
|
|
;; note that merge-flag is ignored if length-pattern
|
|
(cond ((zerop count)
|
|
(setf count -1)
|
|
(return-from pattern:next-for-block +eop+))
|
|
((eql count -1)
|
|
(setf count nil)
|
|
(return-from pattern:next-for-block +eonp+)))
|
|
(while t ;; after rejecting special cases, here is where we return N items
|
|
(cond ((not have-current)
|
|
(send self :advance)
|
|
(setf have-current t)
|
|
(if trace (send self :write-trace "advanced to" current))))
|
|
(cond ((not is-nested) ;; now current is updated
|
|
(setf have-current nil)
|
|
(decf count)
|
|
(return-from pattern:next-for-block current)))
|
|
;; is-nested, so get item from sub-pattern
|
|
(let ((rslt (send current :next)))
|
|
(cond ((eq rslt +eonp+)
|
|
;; time to advance because sub-pattern has played out
|
|
(setf have-current nil))
|
|
((eq rslt +eop+)) ;; skip ends of periods; we merge them
|
|
(t
|
|
(decf count)
|
|
(return-from pattern:next-for-block rslt))))))))
|
|
|
|
;; :next-natural returns the next value, including +eop+ and +eonp+ markers
|
|
;; this code handles the cases where :for is not specified, so the length
|
|
;; of each period is implicitly determined from the pattern
|
|
;;
|
|
(send pattern-class :answer :next-natural '()
|
|
'((block pattern:next-natural-block ;; so we can return from inside while loop
|
|
(xm-traceif ":next-natural current" current)
|
|
(while t
|
|
(cond ((null count)
|
|
(setf have-current nil)
|
|
;; :merge parameter is not used by every pattern, but it does not
|
|
;; hurt to evaluate it here
|
|
(setf merge-flag (if merge-pattern (next merge-pattern)))
|
|
(send self :start-period nil))) ;; sets count
|
|
(xm-traceif "count" count "is-nested" is-nested)
|
|
(cond (is-nested
|
|
(cond ((zerop count)
|
|
(cond (merge-flag ;; we filtered out +eop+; return one here
|
|
(setf count -1)
|
|
(return-from pattern:next-natural-block +eop+))
|
|
(t
|
|
(setf count nil)
|
|
(return-from pattern:next-natural-block +eonp+))))
|
|
((eql count -1)
|
|
(setf count nil)
|
|
(return-from pattern:next-natural-block +eonp+))))
|
|
(t
|
|
(cond ((zerop count)
|
|
(setf count -1)
|
|
(return-from pattern:next-natural-block +eop+))
|
|
((eql count -1)
|
|
(setf count nil)
|
|
(return-from pattern:next-natural-block +eonp+)))))
|
|
(cond ((not have-current)
|
|
(send self :advance)
|
|
(setf have-current t)
|
|
(if trace (send self :write-trace "advanced to" current))
|
|
(xm-traceif ":advance current" current)))
|
|
(cond ((not is-nested)
|
|
(setf have-current nil)
|
|
(decf count)
|
|
(return-from pattern:next-natural-block current)))
|
|
;; nested, so get sub-pattern's next item or +eonp+ or +eop+
|
|
(let ((rslt (send current :next)))
|
|
(xm-traceif "in :next-natural got from sub-pattern " rslt)
|
|
(cond ((eq rslt +eonp+)
|
|
(setf have-current nil) ;; force advance next time, don't
|
|
;; return +eonp+ until count == 0
|
|
(decf count))
|
|
((and (eq rslt +eop+) merge-flag)) ;; iterate, skip +eop+
|
|
(t
|
|
(return-from pattern:next-natural-block rslt))))))))
|
|
|
|
|
|
|
|
(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)))
|
|
(xm-traceif ":set-current" name "value" value)
|
|
)))
|
|
|
|
|
|
;; get-pattern-name - used for debugging, handles non-patterns safely
|
|
;;
|
|
(defun get-pattern-name (pattern)
|
|
(cond ((patternp pattern) (send pattern :name))
|
|
(t pattern)))
|
|
|
|
|
|
;; more debugging support
|
|
(setf xm-next-nesting -1)
|
|
(setf *xm-trace* nil)
|
|
|
|
;; use xm-traceif for verbose printing. It only prints if *xm-trace*
|
|
;;
|
|
(defun xm-traceif (&rest items)
|
|
(if *xm-trace* (apply #'xm-trace items)))
|
|
|
|
;; use xm-traceif-return for verbose printing of return values.
|
|
;; It only prints if *xm-trace*. Includes decrement of xm-next-nesting.
|
|
;;
|
|
(defun xm-traceif-return (method pattern val)
|
|
(xm-traceif method (get-pattern-name pattern) "returning" val)
|
|
(decf xm-next-nesting)
|
|
val)
|
|
|
|
;; use xm-trace for normal tracing enabled by the trace flag in patterns
|
|
;;
|
|
(defun xm-trace (&rest items)
|
|
(princ "|")
|
|
(dotimes (i xm-next-nesting) (princ " |"))
|
|
(dolist (item items) (princ item) (princ " "))
|
|
(terpri))
|
|
|
|
|
|
;; next -- get the next element in a pattern
|
|
;;
|
|
;; any non-pattern value is simply returned
|
|
;;
|
|
(defun next (pattern &optional period-flag)
|
|
(incf xm-next-nesting)
|
|
(xm-traceif "next" (get-pattern-name pattern) period-flag)
|
|
(cond ((and period-flag (patternp pattern))
|
|
(let (rslt elem)
|
|
(incf xm-next-nesting)
|
|
(xm-traceif "next sending :next to" (get-pattern-name pattern))
|
|
(while (not (eq (setf elem (send pattern :next)) +eop+))
|
|
(xm-traceif "next got" elem "from" (get-pattern-name pattern))
|
|
(if (not (eq elem +eonp+))
|
|
(push elem rslt))
|
|
(if (null elem) (error "got null elem"))) ;;;;;;;; DEBUG ;;;;;;;;;;;
|
|
(decf xm-next-nesting)
|
|
(xm-traceif-return "next" pattern (reverse rslt))))
|
|
(period-flag
|
|
(xm-traceif "next with period-flag" (get-pattern-name pattern))
|
|
(error (format nil "~A, next expected a pattern"
|
|
(get-pattern-name pattern))))
|
|
((patternp pattern)
|
|
(xm-traceif "next with pattern" (get-pattern-name pattern) pattern)
|
|
(let (rslt)
|
|
(dotimes (i 10000 (error
|
|
(format nil
|
|
"~A, just retrieved 10000 empty periods -- is there a bug?"
|
|
(get-pattern-name pattern))))
|
|
(if (not (member (setf rslt (send pattern :next))
|
|
'(+eop+ +eonp+)))
|
|
(return (xm-traceif-return "next" pattern rslt))))))
|
|
(t ;; pattern not a pattern, so just return it:
|
|
(xm-traceif "next not pattern" pattern)
|
|
(xm-traceif-return "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)
|
|
'((send-super :isnew nil l nm tr) ;; note: no merge pattern is applicable
|
|
(setf pattern p)))
|
|
|
|
;; 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 '(forcount)
|
|
'((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 mp for nm tr)
|
|
'((send-super :isnew mp for nm tr)
|
|
(cond ((patternp l)
|
|
(setf lis-pattern l))
|
|
((listp l)
|
|
(send self :set-list l tr))
|
|
(t
|
|
(error (format nil "~A, expected list" nm) l)))))
|
|
|
|
|
|
(send cycle-class :answer :set-list '(l tr)
|
|
'((setf lis l)
|
|
(check-for-list lis "cycle-class :set-list")
|
|
(setf is-nested (list-has-pattern lis))
|
|
(setf lis (make-homogeneous lis tr))))
|
|
|
|
|
|
(send cycle-class :answer :start-period '(forcount)
|
|
'((xm-traceif "cycle-class :start-period" "lis-pattern"
|
|
(get-pattern-name lis-pattern) "lis" lis "count" count
|
|
"length-pattern" (get-pattern-name length-pattern))
|
|
(cond (lis-pattern
|
|
(send self :set-list (next lis-pattern t) trace)))
|
|
;; notice that list gets reset at the start of the period
|
|
(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 merge for (name "cycle") trace)
|
|
(check-for-list-or-pattern lis "make-cycle")
|
|
(send cycle-class :new lis merge for name trace))
|
|
|
|
;; ---- LINE class ----
|
|
|
|
(setf line-class (send class :new '(lis cursor lis-pattern)
|
|
'() pattern-class))
|
|
|
|
(send line-class :answer :isnew '(l mp for nm tr)
|
|
'((send-super :isnew mp for nm tr)
|
|
(cond ((patternp l)
|
|
(setf lis-pattern l))
|
|
((listp l)
|
|
(send self :set-list l tr))
|
|
(t
|
|
(error (format nil "~A, expected list" nm) l)))))
|
|
|
|
|
|
(send line-class :answer :set-list '(l tr)
|
|
'((setf lis l)
|
|
(check-for-list lis "line-class :set-list")
|
|
(setf is-nested (list-has-pattern lis))
|
|
(setf lis (make-homogeneous l tr))
|
|
(setf cursor lis)))
|
|
|
|
|
|
(send line-class :answer :start-period '(forcount)
|
|
'((cond (lis-pattern
|
|
(send self :set-list (next lis-pattern t) trace)
|
|
(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 merge for (name "line") trace)
|
|
(check-for-list-or-pattern lis "make-line")
|
|
(send line-class :new lis merge 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 max-pattern min min-pattern)
|
|
(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 set-rand-item-max (item max) (setf (car (cdddr item)) max))
|
|
(defun rand-item-max-pattern(item) (car (cddddr item)))
|
|
|
|
(defun rand-item-min (lis) (cadr (cddddr lis)))
|
|
(defun set-rand-item-min (item min) (setf (car (cdr (cddddr item))) min))
|
|
(defun rand-item-min-pattern(item) (car (cddr (cddddr item))))
|
|
|
|
|
|
(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))
|
|
(loop
|
|
(setf sum (- sum (rand-item-weight (car items))))
|
|
(if (<= sum 0) (return (car items)))
|
|
(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) minpat maxpat 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 minpat (cadr lis)))
|
|
((eq (car lis) :max)
|
|
(setf maxpat (cadr lis)))
|
|
(t
|
|
(error "(make-random) item syntax error" item)))
|
|
(setf lis (cddr lis)))
|
|
(list value nil wp nil maxpat nil minpat)))
|
|
|
|
|
|
(defun random-atom-to-list (a)
|
|
(if (atom a)
|
|
(list a nil 1 nil nil nil nil)
|
|
(random-convert-spec a)))
|
|
|
|
|
|
(send random-class :answer :isnew '(l mp 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
|
|
'((xm-traceif "random :isnew list" l "merge" mp "for" for "name" nm "trace" tr)
|
|
(send-super :isnew mp for nm tr)
|
|
(cond ((patternp l)
|
|
(setf lis-pattern l))
|
|
((listp l)
|
|
(send self :set-list l))
|
|
(t
|
|
(error (format nil "~A, expected list") l)))))
|
|
|
|
|
|
(send random-class :answer :set-list '(l)
|
|
'((check-for-list l "random-class :set-list")
|
|
(setf lis (mapcar #'random-atom-to-list l))
|
|
; (display "random set-list" lis)
|
|
(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))
|
|
(xm-traceif "random is-new" name lis)
|
|
(setf repeats 0)
|
|
(setf len (length lis))))
|
|
|
|
|
|
(send random-class :answer :start-period '(forcount)
|
|
'((xm-traceif "random-class :start-period" name "count" count "len" len
|
|
"lis" lis "lis-pattern" (get-pattern-name 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)))
|
|
(set-rand-item-max item (next (rand-item-max-pattern item)))
|
|
(set-rand-item-min item (next (rand-item-min-pattern item))))
|
|
; (display "random start-period" lis-pattern lis)
|
|
))
|
|
|
|
|
|
(send random-class :answer :advance '()
|
|
'((let (selection (iterations 0))
|
|
(xm-traceif "random-class :advance" name "mincnt" mincnt
|
|
"repeats" repeats)
|
|
(cond ((and mincnt (< repeats mincnt))
|
|
(setf selection previous))
|
|
(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
|
|
; notice that we could have selected based on an older maxcnt and
|
|
; maxcnt may now be smaller. This is allowed. Perhaps another
|
|
; rule would be better, e.g. update maxcnt and check against it
|
|
; with each selection.
|
|
(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)
|
|
(xm-traceif "new selection" name "repeats" repeats "mincnt" mincnt
|
|
"maxcnt" maxcnt "selection" selection)
|
|
(send self :set-current (rand-item-value selection)))))
|
|
|
|
|
|
(defun make-random (lis &key merge for (name "random") trace)
|
|
(check-for-list-or-pattern lis "make-random")
|
|
(send random-class :new lis merge 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 tr)
|
|
'((setf lis l)
|
|
(check-for-list lis "palindrome-class :start-period")
|
|
(setf is-nested (list-has-pattern lis))
|
|
(setf lis (make-homogeneous l tr))
|
|
(send self :set-cursor)))
|
|
|
|
(send palindrome-class :answer :set-cursor '()
|
|
'((setf revlis (reverse lis)
|
|
direction t
|
|
cursor lis)))
|
|
|
|
|
|
(send palindrome-class :answer :isnew '(l e mp for nm tr)
|
|
'((send-super :isnew mp for nm tr)
|
|
(cond ((patternp l)
|
|
(setf lis-pattern l))
|
|
((listp l)
|
|
(send self :set-list l tr))
|
|
(t
|
|
(error (format nil "~A, expected list" nm) l)))
|
|
(setf elide-pattern e)))
|
|
|
|
|
|
(send palindrome-class :answer :start-period '(forcount)
|
|
'((cond (lis-pattern
|
|
(send self :set-list (next lis-pattern t) trace)))
|
|
;; like cycle, list is reset at the start of the period
|
|
(send self :set-cursor)
|
|
(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)))))
|
|
(if (<= count 0)
|
|
(error (format nil "palindrome ~A period is <= 0"
|
|
(get-pattern-name self))))))
|
|
|
|
|
|
(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)
|
|
(xm-traceif "palindrome at end" (get-pattern-name self)
|
|
"current" (get-pattern-name (car cursor)))
|
|
(send self :next-item))
|
|
(t ;; direction is reverse
|
|
(setf direction t)
|
|
(setf cursor lis)
|
|
(send self :next-item)))))
|
|
|
|
|
|
(defun make-palindrome (lis &key elide merge for (name "palindrome") trace)
|
|
(check-for-list-or-pattern lis "make-palindrome")
|
|
(send palindrome-class :new lis elide merge 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 maxcnt-pattern prev
|
|
check-repeat lis-pattern len)
|
|
'() pattern-class))
|
|
|
|
(send heap-class :answer :isnew '(l mp for mx nm tr)
|
|
'((send-super :isnew mp for 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) tr))
|
|
(t
|
|
(error (format nil "~A, expected list" nm) l)))
|
|
(cond ((patternp mx)
|
|
(setf maxcnt-pattern mx))
|
|
((not (numberp mx))
|
|
(error (format nil "~A, expected number" nm) mx))
|
|
(t
|
|
(setf maxcnt mx)))))
|
|
|
|
|
|
(send heap-class :answer :set-list '(l tr)
|
|
'((setf lis l)
|
|
(check-for-list lis "heap-class :set-list")
|
|
(setf is-nested (list-has-pattern lis))
|
|
(setf lis (make-homogeneous lis tr))
|
|
(setf len (length lis))))
|
|
|
|
|
|
(send heap-class :answer :start-period '(forcount)
|
|
'((xm-traceif "heap-class :start-period" name "lis-pattern"
|
|
(get-pattern-name lis-pattern) "count" count "lis" lis)
|
|
(cond (lis-pattern
|
|
(send self :set-list (next lis-pattern t) trace)))
|
|
(cond (maxcnt-pattern
|
|
(setf maxcnt (next maxcnt-pattern))))
|
|
; 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 merge for (max 2) (name "heap") trace)
|
|
(send heap-class :new lis merge for max name trace))
|
|
|
|
;;================== COPIER CLASS ====================
|
|
|
|
(setf copier-class (send class :new '(sub-pattern repeat repeat-pattern
|
|
period cursor)
|
|
'() pattern-class))
|
|
|
|
(send copier-class :answer :isnew '(p r m for nm tr)
|
|
'((send-super :isnew m for nm tr)
|
|
(setf sub-pattern p repeat-pattern r)))
|
|
|
|
|
|
#| 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-flag 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 '(forcount)
|
|
'((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 '()
|
|
'((xm-traceif "copier-class :really-start-period" name "count" count)
|
|
(setf repeat (next repeat-pattern))
|
|
(while (minusp repeat)
|
|
(dotimes (i (- repeat))
|
|
(setf period (next sub-pattern t)))
|
|
(setf repeat (next repeat-pattern))
|
|
(setf merge-flag (next merge-pattern)))
|
|
|
|
; (print "** STARTING NEXT PATTERN IN COPIER-CLASS")
|
|
|
|
(setf period (next sub-pattern t))
|
|
|
|
; (display "copier-class really-start-period got" period)
|
|
; (print "** ENDING NEXT PATTERN IN COPIER-CLASS")
|
|
|
|
(setf cursor nil)
|
|
(if (null count)
|
|
(setf count (* (if merge-flag repeat 1)
|
|
(length period))))))
|
|
|
|
|
|
(send copier-class :answer :advance '()
|
|
'((let ((loop-count 0))
|
|
(loop
|
|
(xm-traceif "copier loop" name "repeat" repeat "cursor" cursor
|
|
"period" 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 minimum maximum)
|
|
'() pattern-class))
|
|
|
|
|
|
(send accumulate-class :answer :isnew '(p mp for nm tr mn mx)
|
|
'((send-super :isnew mp for nm tr)
|
|
(setf sub-pattern p sum 0 mini mn maxi mx)
|
|
;(xm-trace "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 '(forcount)
|
|
'((cond ((null count)
|
|
(send self :really-start-period)))))
|
|
|
|
(send accumulate-class :answer :really-start-period '()
|
|
|#
|
|
|
|
|
|
(send accumulate-class :answer :start-period '(forcount)
|
|
'((setf period (next sub-pattern t))
|
|
(setf cursor period)
|
|
(xm-traceif "accumulate-class :start-period" name "period" period
|
|
"cursor" cursor "count" count)
|
|
(if maxi (setf maximum (next maxi)))
|
|
(if mini (setf minimum (next mini)))
|
|
(if (null count)
|
|
(setf count (length period)))))
|
|
|
|
|
|
(send accumulate-class :answer :advance '()
|
|
'((let ((loop-count 0))
|
|
(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 :start-period nil)))
|
|
(incf loop-count)))))
|
|
|
|
|
|
(defun make-accumulate (sub-pattern &key merge for min max (name "accumulate") trace)
|
|
(send accumulate-class :new sub-pattern merge 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 mp for nm tr)
|
|
'((send-super :isnew mp 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)))))
|
|
|
|
|
|
(send accumulation-class :answer :set-list '(l)
|
|
'((setf lis l)
|
|
(check-for-list lis "heap-class :set-list")
|
|
(setf lis (make-homogeneous lis trace))
|
|
(setf inner lis)
|
|
(setf outer lis)
|
|
(setf len (length lis))))
|
|
|
|
(send accumulation-class :answer :start-period '(forcount)
|
|
'((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 merge for (name "accumulation") trace)
|
|
(send accumulation-class :new lis merge 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 mp for nm tr)
|
|
'((send-super :isnew mp for nm tr)
|
|
(setf x xx y yy 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 '(forcount)
|
|
'((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 merge for (name "sum") trace)
|
|
(send sum-class :new x y merge for name trace))
|
|
|
|
|
|
;;================== PRODUCT CLASS =================
|
|
|
|
(setf product-class (send class :new '() '() sum-class))
|
|
|
|
(send product-class :answer :isnew '(xx yy mp for nm tr)
|
|
'((send-super :isnew xx yy mp for nm tr)
|
|
(setf x xx y yy fn #'*)))
|
|
|
|
(defun make-product (x y &key merge for (name "product") trace)
|
|
(send product-class :new x y merge for name trace))
|
|
|
|
|
|
;;================== EVAL CLASS =================
|
|
;;
|
|
;; (1) if :for, then period is determined by :for and we should
|
|
;; just fetch the next item from expr-pattern or use expr
|
|
;; (this case is length-pattern)
|
|
;; (2) if expr-pattern and not :for, then we should fetch a whole
|
|
;; period from expr-pattern and use it to determine period len
|
|
;; (this case is (and expr-pattern (not length-pattern)))
|
|
;; (3) if not expr-pattern and not :for, then the pattern len is 1
|
|
;; (this case is (and (not expr-pattern) (not length-pattern)))
|
|
|
|
(setf eval-class (send class :new '(expr expr-pattern)
|
|
'() pattern-class))
|
|
|
|
(send eval-class :answer :isnew '(e mp for nm tr)
|
|
'((send-super :isnew mp for nm tr)
|
|
(cond ((patternp e)
|
|
(setf expr-pattern e))
|
|
(t
|
|
(setf expr e)))))
|
|
|
|
|
|
(send eval-class :answer :start-period '(forcount)
|
|
'((xm-traceif "eval-class :start-period" name "lis-pattern"
|
|
(get-pattern-name expr-pattern) "expr" expr "count" count
|
|
"length-pattern" (get-pattern-name expr-pattern))
|
|
(cond (length-pattern t) ;; case 1
|
|
(expr-pattern ;; case 2
|
|
(setf expr (next expr-pattern t))
|
|
(setf count (length expr)))
|
|
(t ;; case 3
|
|
(setf count 1)))))
|
|
|
|
|
|
(send eval-class :answer :advance '()
|
|
'((send self :set-current
|
|
(cond ((and length-pattern expr-pattern)
|
|
(eval (next expr-pattern)))
|
|
(length-pattern
|
|
(eval expr))
|
|
(expr-pattern
|
|
(let ((item (car expr)))
|
|
(setf expr (cdr expr))
|
|
item))
|
|
(t (eval expr))))))
|
|
|
|
|
|
(defun make-eval (expr &key merge (for 1) (name "eval") trace)
|
|
(send eval-class :new expr merge 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))
|
|
(xm-traceif "is-produces-homogeneous type" type)
|
|
(setf *rslt* (eq type 'pattern))
|
|
(xm-traceif "is-produces-homogeneous *rslt*" *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 mp for nm tr)
|
|
;; input parameters are rules, order, state, produces, for, name, trace
|
|
'((send-super :isnew mp for nm tr)
|
|
(setf order o state s produces p)
|
|
(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))
|
|
(xm-traceif "markov-class isnew" name "entry" entry "rule" rule
|
|
"targets" targets "order" 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))))
|
|
(xm-traceif "markov-class :isnew" name "is-nested" *rslt*)
|
|
(setf is-nested *rslt*) ;; returned by is-produces-homogeneous
|
|
))
|
|
|
|
|
|
(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-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)))
|
|
(let ((rslt (cadr produces)))
|
|
(if (not rslt) (setf rslt target)) ;; if lookup fails return target
|
|
(if (patternp rslt) (setf rslt (next rslt)))
|
|
rslt))
|
|
|
|
|
|
(send markov-class :answer :sum-of-weights '(rule)
|
|
'((let ((sum 0.0))
|
|
(dolist (target (cdr rule))
|
|
(xm-traceif "markov-sum-of-weights" name "target" target)
|
|
(setf sum (+ sum (second target))))
|
|
sum)))
|
|
|
|
|
|
(send markov-class :answer :find-rule '()
|
|
'((let (rslt)
|
|
(xm-traceif "markov-class find-rule" name "rules" rules)
|
|
(dolist (rule rules)
|
|
(xm-traceif "markov find-rule" name "state" state "rule" 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 '(forcount)
|
|
'((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)
|
|
(xm-traceif "markov :advance" name "pattern" pattern "rules" rules)
|
|
(setf rule (send self :find-rule))
|
|
(markov-update-weights rule)
|
|
(xm-traceif "markov sum-of-weights" name "rule" rule)
|
|
(setf sum (send self :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
|
|
(xm-trace "markov state replacement" name
|
|
"new-state" new-state "target" target)
|
|
(setf state new-state)))))
|
|
(setf state (append (cdr state) (list target)))
|
|
(xm-traceif "markov next" name "rule" rule "sum" sum "target" target
|
|
"state" 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))
|
|
(xm-traceif "markov-produce" name "target" target
|
|
"produces" 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 merge 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 merge 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)
|
|
(xm-traceif "markov find-rule" name "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)
|
|
'((send-super :isnew nil for nm tr)
|
|
(setf pattern p skip-pattern sk)))
|
|
|
|
|
|
(send window-class :answer :start-period '(forcount)
|
|
'((if (null length-pattern)
|
|
(error (format nil "~A, :start-period -- length-pattern is null"
|
|
name)))
|
|
(setf count forcount)
|
|
(cond ((null lis) ;; first time
|
|
(dotimes (i count)
|
|
(push (next pattern) lis))
|
|
(setf lis (reverse lis))
|
|
(setf cursor lis))
|
|
(t
|
|
(let ((skip (next skip-pattern)))
|
|
(dotimes (i skip)
|
|
(if lis (pop lis) (next pattern))))
|
|
(setf lis (reverse lis))
|
|
;; now lis is in reverse order; if not long enough, push
|
|
(let ((len (length lis)) rslt)
|
|
(while (< len count)
|
|
(incf len)
|
|
(push (next pattern) lis))
|
|
(setf lis (reverse lis))
|
|
;; lis is in order, copy it to rstl and take what we need
|
|
(setf rslt (reverse (append lis nil))) ;; copy lis
|
|
(while (> len count)
|
|
(decf len)
|
|
(pop rslt))
|
|
(setf cursor (reverse rslt)))))
|
|
(xm-traceif "window start-period cursor" cursor "lis" 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 must-be-valid-score (caller score)
|
|
(if (not (score-validp score))
|
|
(error (strcat "In " caller ", not a valid score") score)))
|
|
|
|
(defun invalid-score () (return-from validp nil))
|
|
(defun score-validp (score)
|
|
(block validp
|
|
(if (listp score) nil (invalid-score)) ;; tricky: return nil if NOT condition
|
|
(dolist (event score)
|
|
(if (listp event) nil (invalid-score))
|
|
(if (and (event-time event) (numberp (event-time event))) nil
|
|
(invalid-score))
|
|
(if (and (event-dur event) (numberp (event-dur event))) nil
|
|
(invalid-score))
|
|
(if (and (event-expression event) (consp (event-expression event))) nil
|
|
(invalid-score)))
|
|
t))
|
|
|
|
(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))
|
|
(begin (cadr (event-expression (car score))))
|
|
(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 begin (min begin (event-time event)))
|
|
(setf end (max end (event-end event)))))
|
|
(setf result (push-sort event result))
|
|
(incf i))
|
|
(cons (list 0 0 (list 'SCORE-BEGIN-END begin 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))
|
|
(if (zerop factor) (print "WARNING: score-stretch called with zero stretch factor."))
|
|
(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)))))
|
|
|
|
|
|
;; Turn a value field 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 (v)
|
|
(cond ((and v (symbolp v) (boundp v) (numberp (symbol-value v)))
|
|
(symbol-value v))
|
|
(t v)))
|
|
|
|
|
|
(defun params-transpose (params keyword amount)
|
|
(cond ((null params) nil)
|
|
((eq keyword (car params))
|
|
(let ((v (get-numeric-value (cadr params))))
|
|
(cond ((numberp v)
|
|
(setf v (+ v amount)))
|
|
((and (eq keyword :pitch) (listp v))
|
|
(setf v (mapcar #'(lambda (x) (setf x (get-numeric-value x))
|
|
(+ x amount)) v))))
|
|
(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 (cadr 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)))
|
|
|
|
|
|
;; MAP-VOICE - helper function for SCORE-VOICE
|
|
;; input: a score expression, e.g. '(note :pitch 60 :vel 100)
|
|
;; a replacement list, e.g. '((note foo) (* bar))
|
|
;; output: the score expression with substitutions, e.g.
|
|
;; '(foo :pitch 60 :vel 100)
|
|
;;
|
|
(defun map-voice (expression replacement-list)
|
|
(cond (replacement-list
|
|
(cond ((or (eq (car expression) (caar replacement-list))
|
|
(eq (caar replacement-list) '*))
|
|
(cons (cadar replacement-list) (cdr expression)))
|
|
(t (map-voice expression (cdr replacement-list)))))
|
|
(t expression)))
|
|
|
|
|
|
(defun ny:assert-replacement-list (fun-name index formal actual)
|
|
(let ((lis actual) r)
|
|
(while lis
|
|
(if (not (consp actual))
|
|
(error (format nil "In ~A,~A argument (~A) should be a list, got ~A"
|
|
fun-name (index-to-string index) formal actual)))
|
|
(setf r (car lis))
|
|
(if (not (and (listp r) (= 2 (length r)) (symbolp (car r)) (symbolp (cadr r))))
|
|
(error (format nil
|
|
"In ~A,~A argument (~A) should be a list of lists of two symbols, got ~A"
|
|
fun-name (index-to-string index) formal actual)))
|
|
(setf lis (cdr lis)) )))
|
|
|
|
|
|
(defun score-voice (score replacement-list &key
|
|
from-index to-index from-time to-time)
|
|
(ny:assert-replacement-list 'SCORE-VOICE 2 "replacement-list" replacement-list)
|
|
(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 &optional lines)
|
|
(let ((len (length score))) ;; len will be how many events left
|
|
(format t "(")
|
|
(cond (lines
|
|
(setf lines (max lines 3))) ;; always allow up to 3 lines
|
|
(t ;; no limit on lines, pick a conservatively large number
|
|
(setf lines (+ 100 len))))
|
|
(dolist (event score)
|
|
(cond ((or (> lines 2) (= 1 len))
|
|
;; print if we have more than 2 lines left to print or
|
|
;; if we are at the last line (always printed)
|
|
(format t "~S~%" event)
|
|
(setf lines (1- lines)))
|
|
((and (= lines 2) (> len 2)) ;; need ellipsis
|
|
(format t "... skipping ~A events ...~%" (- len lines))
|
|
(setf lines (1- lines)))
|
|
(t nil)) ;; print nothing until end if lines is 1
|
|
(setf len (1- len)))
|
|
(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 absolute)
|
|
(score-write-smf score filename programs t absolute))
|
|
|
|
(defun score-write-smf (score filename &optional programs as-adagio absolute)
|
|
(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))))))
|
|
(cond (as-adagio
|
|
(seq-write seq file absolute)
|
|
(close file)) ;; seq-write does not close file, so do it here
|
|
(t
|
|
(seq-write-smf seq file))))))) ; seq-write-smf closes 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 "piano/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 NyquistIDE
|
|
|
|
(if (not (boundp '*default-score-file*))
|
|
(setf *default-score-file* "score.dat"))
|
|
|
|
;; SCORE-EDIT -- save a score for editing by NyquistIDE
|
|
;;
|
|
;; file goes to a data file to be read by NyquistIDE
|
|
;; 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)))
|