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

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

(in-package :cm)

(defparameter +constant-data+ (ash 1 0))

(defparameter +constant-weights+ (ash 1 1))

(defparameter +count-periods+ (ash 1 2))

(defparameter +count-values+ (ash 1 3))

(defparameter +depth-first+ (ash 1 4))

(defparameter +breadth-first+ (ash 1 5))

(defparameter +coerce-to-note+ (ash 1 6))

(defparameter +coerce-to-pitch+ (ash 1 7))

(defparameter +parallel-offsets+ (ash 1 8))

(defparameter +range-stepping+ (ash 1 10))

(defparameter +range-initially+ (ash 1 11))

(defparameter +range-unbounded+ (ash 1 12))

(defparameter +range-dynamic+ (ash 1 13))

(defparameter +constant-minmax+ (ash 1 14))

(defparameter +default-period+ (ash 1 15))

(defparameter +range-random+ (ash 1 16))

(defparameter +nad+ (quote :not-a-datum))

(defparameter +eop+ (quote :end-of-period))

(defparameter +eod+ (quote :end-of-data))

(define-list-struct period (count 0) length stream default (omit 0)
 (reps 0))

(progn (defclass pattern (container)
         ((flags :initarg :flags :initform 0 :accessor pattern-flags)
          (data :initarg :of :initarg :data :initarg :notes :initarg
           :keynums :initarg :rhythms :initarg :amplitudes :initarg
           :intervals :initform '() :accessor pattern-data)
          (length :accessor pattern-length)
          (datum :initform +nad+ :accessor pattern-datum)
          (period :initarg :for :accessor pattern-period)
          (value :initarg :last-value :initform +nad+ :accessor
           pattern-value)
          (state :initarg :last-state :initform +nad+ :accessor
           pattern-state)
          (repeat :initarg :repeat :initform most-positive-fixnum
           :accessor pattern-repeat)
          (parser :initarg :parser :initform nil :accessor
           pattern-parser)
          (returning :initform nil :initarg :returning :accessor
           pattern-returning)
          (counting :initarg :counting :initform :periods :accessor
           pattern-counting)
          (traversing :initarg :traversing :initform :depth-first
           :accessor pattern-traversing)))
       (defparameter <pattern> (find-class 'pattern))
       (finalize-class <pattern>)
       (values))

(defun maybeparse (fn val)
  (if (or (not fn) (typep val <pattern>)) val (funcall fn val)))

(defmethod canonicalize-pattern-data ((obj pattern)
                                      data
                                      parser
                                      inits)
  inits
  (if parser
      (loop for d in data
            count d into len
            count (pattern? d) into num
            collect (maybeparse parser d) into lst
            finally (return (values lst len (= num 0))))
            (values data (length data) (not (some #'pattern? data)))))

(defmethod make-load-form ((obj pattern))
  (let ((inits (pattern-external-inits obj))
        (gvar
         (intern (format nil "<~a>" (class-name (class-of obj)))
                 :cm)))
    `(make-instance ,gvar ,@inits)))

(defmethod pattern-external-inits ((obj pattern))
  (let ((inits
         (slot-init-forms obj :eval t :ignore-defaults t :only
          '(repeat parser returning counting traversing) :key
          #'expand-pattern-value)))
    (unless (logtest (pattern-flags obj) +default-period+)
      (let ((per (pattern-period obj)))
        (push (expand-pattern-value
               (or (period-stream per) (period-length per)))
              inits)
        (push ':for inits)))
    inits))

(defun expand-pattern-value (val)
  (cond ((pattern? val) (make-load-form val))
        ((consp val)
         (if (eq (first val) 'quote)
             val
             (cons 'list
                   (loop for x in val
                         collect (expand-pattern-value x)))))
         ((and val (symbolp val)) `',val)
         (t val)))

(defmethod pattern-period-length ((obj pattern))
  (period-length (pattern-period obj)))

(defmethod default-period-length ((obj pattern)) (pattern-length obj))

(defmethod initialize-instance :after ((obj pattern) &rest args)
  args
  (let ((flags (pattern-flags obj))
        (data nil)
        (len nil)
        (parser (pattern-parser obj))
        (constant? nil))
    (do ((a args (cddr a)))
        ((or data (null a)) nil)
      (case (car a)
        ((:of :data) (setf data (cadr a)))
        ((:notes) (setf data (cadr a)) (setf parser #'note))
        ((:keynums) (setf data (cadr a)) (setf parser #'keynum))
        ((:rhythms) (setf data (cadr a)) (setf parser #'rhythm))
        ((:amplitudes) (setf data (cadr a))
         (setf parser #'amplitude))))
    (unless (listp data) (setf data (list data)))
    (with-default-octave *scale*
     (multiple-value-setq (data len constant?)
       (canonicalize-pattern-data obj data parser args)))
    (setf (pattern-data obj) data)
    (setf (pattern-length obj) len)
    (let ((counting (pattern-counting obj)))
      (when counting
        (case counting
          ((:periods :period periods period)
           (setf flags (logior flags +count-periods+)))
          ((:values :value values value)
           (setf flags (logior flags +count-values+)))
          (t
           (error "~s not one of 'counting' keywords:  periods values."
                  counting)))))
    (let ((traversing (pattern-traversing obj)))
      (when traversing
        (case traversing
          ((:depth-first :depth depth-first depth)
           (setf flags (logior flags +depth-first+)))
          ((:breadth-first :breadth breadth-first breadth)
           (setf flags (logior flags +breadth-first+)))
          (t
           (error "~s not 'traversing' keword: depth-firs,t breadth-first."
                  traversing)))))
    (when constant? (setf flags (logior flags +constant-data+)))
    (cond ((logtest flags +count-values+)
           (setf flags (logand flags (lognot +count-periods+))))
          (t
           (if (logtest flags +constant-data+)
               (setf flags
                     (logior (logand flags (lognot +count-periods+))
                             +count-values+))
               (setf flags (logior flags +count-periods+)))))
    (let* ((default (default-period-length obj))
           (period
            (if (slot-boundp obj 'period)
                (or (pattern-period obj) default)
                default)))
      (if (and (slot-boundp obj 'period)
               (not (null (slot-value obj 'period))))
          (setf period (slot-value obj 'period))
          (progn (setf period default)
                 (setf flags (logior flags +default-period+))))
      (setf (pattern-period obj)
            (if (or (numberp period) (eq period t))
                (make-period :length period :default default)
                (make-period :stream period :default default))))
    (setf (pattern-flags obj) flags)
    (values)))

(defmethod pattern? (obj) obj nil)

(defmethod pattern? ((obj pattern)) obj)

(defmethod eop? (x) (eq x +eop+))

(defmethod eop? ((x pattern)) (eop? (pattern-state x)))

(defmethod eod? (x) (eq x +eod+))

(defmethod eod? ((x pattern)) (eod? (pattern-value x)))

(defmethod pattern-state (obj) obj +eop+)

(defun next (obj &optional num)
  (if num
      (if (numberp num)
          (let ((l (list nil)))
            (do ((i 0 (+ 1 i)) (e l (cdr e)))
                ((>= i num) (cdr l))
              (rplacd e (list (next-1 obj)))))
          (if (pattern? obj)
              (let ((l (list nil)))
                (do ((n (next-1 obj)) (e l (cdr e)) (f nil))
                    ((or (eq n +eod+) f) (cdr l))
                  (rplacd e (list n))
                  (if (eop? obj) (setf f t) (setf n (next-1 obj)))))
              (list obj)))
      (next-1 obj)))

(defmethod next-1 (obj) obj)

(defmethod next-1 ((obj pattern))
  (let ((period (pattern-period obj)) (nomore nil))
    (when (= (period-count period) 0)
      (when (>= (period-reps period) (pattern-repeat obj))
        (setf (pattern-value obj) +eod+)
        (setf (pattern-state obj) +eop+)
        (setf nomore +eod+))
      (when (and (not nomore) (= (reset-period obj) 0))
        (setf nomore +nad+)
        (setf (pattern-value obj) +nad+)
        (setf (pattern-state obj) +eop+)))
    (if nomore
        nomore
        (let ((flags (pattern-flags obj))
              (retfn (pattern-returning obj))
              (value nil)
              (state nil))
          (if (logtest flags +constant-data+)
              (progn (setf (pattern-datum obj) (next-in-pattern obj))
                     (setf value (next-1 (pattern-datum obj)))
                     (setf state +eop+))
              (loop with dyn? =
                         (and (logtest flags +count-periods+)
                              (eq (period-length period) t))
                    do (loop while (eq (pattern-datum obj) +nad+)
                             do (setf
                                 (pattern-datum obj)
                                 (if
                                  dyn?
                                  (skip-datum? (next-in-pattern obj))
                                  (next-in-pattern obj))))
                             (setf
                              value
                              (next-1 (pattern-datum obj)))
                             (setf
                              state
                              (pattern-state (pattern-datum obj)))
                             (if
                              (eq value +nad+)
                              (setf (pattern-datum obj) value)
                              (return))))
                    (cond ((eq state +eop+)
                           (period-count-set! period
                            (- (period-count period) 1))
                           (setf (pattern-datum obj) +nad+)
                           (setf state nil))
                          (t
                           (when (logtest flags +breadth-first+)
                             (setf (pattern-datum obj) +nad+))
                           (when (logtest flags +count-values+)
                             (period-count-set!
                              period
                              (- (period-count period) 1)))))
                    (if (= (period-count period) 0)
                        (progn (setf state +eop+)
                               (period-reps-set!
                                period
                                (+ 1 (period-reps period))))
                        (setf state state))
                    (if retfn (setf value (funcall retfn value)))
                    (setf (pattern-state obj) state)
                    (setf (pattern-value obj) value)
                    value))))

(defmethod skip-datum? ((obj pattern))
  (let ((period (pattern-period obj)))
    (if (> (period-omit period) 0)
        (progn (period-omit-set! period (- (period-omit period) 1))
               +nad+)
        obj)))

(defmethod skip-datum? (obj) obj)

(defmethod reset-period (obj) obj 1)

(defmethod reset-period ((obj pattern))
  (let ((period (pattern-period obj)) (dyn nil) (len nil))
    (when (period-stream period)
      (period-length-set! period (next-1 (period-stream period))))
    (setf dyn (eq (period-length period) t))
    (setf len
          (if dyn (period-default period) (period-length period)))
    (when (and dyn (logtest (pattern-flags obj) +count-periods+))
      (let ((zeros 0))
        (map-pattern-data
         #'(lambda (x)
             (when (= (reset-period x) 0)
               (let ((p (pattern-period x)))
                 (period-omit-set! p (+ (period-omit p) 1)))
               (incf zeros)))
         obj)
        (when (> zeros 0) (setf len (max (- len zeros) 0)))))
    (period-count-set! period len)
    len))

(progn (defclass cycle (pattern) nil)
       (defparameter <cycle> (find-class 'cycle))
       (finalize-class <cycle>)
       (values))

(defmethod pattern-external-inits ((obj cycle))
  (append (list ':of
                (cons 'list
                      (loop for x in (car (pattern-data obj))
                            collect (expand-pattern-value x))))
                (call-next-method)))

(defmethod initialize-instance :after ((obj cycle) &rest args)
  args
  (let ((cyc (make-cycl)))
    (cycl-data-set! cyc (pattern-data obj))
    (setf (pattern-data obj) cyc)
    (values)))

(defmethod next-in-pattern ((obj cycle))
  (let ((cyc (pattern-data obj)))
    (if (null (cycl-tail cyc)) (cycl-tail-set! cyc (cycl-data cyc)))
    (pop-cycl cyc)))

(defmethod map-pattern-data (fn (obj cycle))
  (map nil fn (cycl-data (pattern-data obj))))

(progn (defclass palindrome (pattern)
         ((elide :initform nil :initarg :elide :accessor
           palindrome-elide)))
       (defparameter <palindrome> (find-class 'palindrome))
       (finalize-class <palindrome>)
       (values))

(defmethod pattern-external-inits ((obj palindrome))
  (append (list ':of
                (cons 'list
                      (loop for x in (car (pattern-data obj))
                            collect (expand-pattern-value x))))
                (call-next-method)
                (if (not (palindrome-elide obj))
                    (list)
                    (list ':elide
                          (expand-pattern-value
                           (palindrome-elide obj))))))

(defmethod map-pattern-data (fn (obj palindrome))
  (map nil fn (cycl-data (pattern-data obj))))

(defmethod default-period-length ((obj palindrome))
  (* 2 (pattern-length obj)))

(defmethod initialize-instance :after ((obj palindrome) &rest args)
  args
  (let ((cyc (make-cycl)))
    (cycl-data-set! cyc (pattern-data obj))
    (setf (pattern-data obj) cyc)
    (values)))

(defmethod next-in-pattern ((obj palindrome))
  (let ((cycl (pattern-data obj)))
    (when (null (cycl-tail cycl))
      (let ((mode (next-1 (palindrome-elide obj)))
            (half (cycl-data cycl))
            (next '())
            (long (pattern-length obj))
            (bits (pattern-flags obj)))
        (cond ((eq mode t)
               (setf long (- (* long 2) 2))
               (setf next (append half (cdr (reverse (cdr half))))))
              ((not mode)
               (setf long (* long 2))
               (setf next (append half (reverse half))))
              ((member mode
                       '(:first first :start start :left left)
                       :test
                       #'eq)
               (setf long (- (* long 2) 1))
               (setf next (append half (reverse (cdr half)))))
              ((member mode
                       '(:last last :end end :right right)
                       :test
                       #'eq)
               (setf long (- (* long 2) 1))
               (setf next (append half (cdr (reverse half)))))
              (t
               (error "~s is not an elide value: ~s, ~s, :first, :last."
                      mode
                      true
                      false)))
        (when (logtest bits +default-period+)
          (period-count-set! (pattern-period obj) long))
        (cycl-tail-set! cycl next)))
    (pop-cycl cycl)))

(progn (defclass line (pattern) nil)
       (defparameter <line> (find-class 'line))
       (finalize-class <line>)
       (values))

(defmethod pattern-external-inits ((obj line))
  (append (list ':of
                (cons 'list
                      (loop for x in (car (pattern-data obj))
                            collect (expand-pattern-value x))))
                (call-next-method)))

(defmethod initialize-instance :after ((obj line) &rest args)
  args
  (let ((cyc (make-cycl)))
    (cycl-data-set! cyc (pattern-data obj))
    (cycl-tail-set! cyc (cycl-data cyc))
    (setf (pattern-data obj) cyc)
    (values)))

(defmethod next-in-pattern ((obj line))
  (let ((cycl (pattern-data obj)))
    (if (null (cdr (cycl-tail cycl)))
        (car (cycl-tail cycl))
        (pop-cycl cycl))))

(defmethod reset-period :before ((obj line))
  (if (null (cdr (cycl-tail (pattern-data obj))))
      (setf (pattern-length obj) 1)))

(defmethod map-pattern-data (fn (obj line))
  (map nil fn (cycl-data (pattern-data obj))))

(progn (defclass heap (cycle)
         ((random-state :initform *random-state* :initarg :state
           :accessor pattern-random-state)))
       (defparameter <heap> (find-class 'heap))
       (finalize-class <heap>)
       (values))

(defmethod pattern-external-inits ((obj heap))
  (let ((inits (call-next-method)))
    (if (eq *random-state* (pattern-random-state obj))
        inits
        (append inits (list :state (pattern-random-state obj))))))

(defmethod initialize-instance :after ((obj heap) &rest args)
  args
  (let ((cyc (pattern-data obj)))
    (cycl-data-set! cyc (copy-list (cycl-data cyc)))
    (values)))

(defmethod next-in-pattern ((obj heap))
  (flet ((shufl (lis len state)
           (loop for i below len
                 for j = (random len state)
                 for v = (elt lis i)
                 do (setf (elt lis i) (elt lis j))
                    (setf (elt lis j) v))
                 lis))
         (let ((cyc (pattern-data obj)))
           (if (null (cycl-tail cyc))
               (cycl-tail-set! cyc
                (shufl (cycl-data cyc) (pattern-length obj)
                 (pattern-random-state obj))))
           (pop-cycl cyc))))

(defparameter *random-range* ())

(define-list-struct random-item datum index (weight 1) (min 1) max
 (count 0) id minmax)

(progn (defclass random (pattern)
         ((range :initform *random-range* :accessor
           random-pattern-range)
          (random-state :initform *random-state* :initarg :state
           :accessor pattern-random-state)))
       (defparameter <random> (find-class 'random))
       (finalize-class <random>)
       (values))

(defmethod pattern-external-inits ((obj random))
  (flet ((fnc (n)
           (let ((dat (expand-pattern-value (random-item-datum n)))
                 (lst (list)))
             (unless (null (random-item-max n))
               (push (expand-pattern-value (random-item-max n)) lst)
               (push ':max lst))
             (unless (or (not (numberp (random-item-min n)))
                         (= (random-item-min n) 1))
               (push (expand-pattern-value (random-item-min n)) lst)
               (push ':min lst))
             (unless (and (numberp (random-item-weight n))
                          (= (random-item-weight n) 1))
               (push (expand-pattern-value (random-item-weight n))
                     lst)
               (push ':weight lst))
             (if (null lst) dat (cons 'list (cons dat lst))))))
    (let ((lst (call-next-method)))
      (append (list :of
                    (cons 'list
                          (loop for x in (car (pattern-data obj))
                                collect (fnc x))))
                    lst
                    (if (eq *random-state*
                            (pattern-random-state obj))
                        (list)
                        (list :state (pattern-random-state obj)))))))

(defmethod default-period-length ((obj random))
  (do ((tail (pattern-data obj) (cdr tail)) (flag t))
      ((or (not flag) (null tail)) (if flag 1 (pattern-length obj)))
    (setf flag (pattern? (random-item-datum (car tail))))))

(defmethod initialize-instance :after ((obj random) &rest args)
  args
  (let ((pool (pattern-data obj))
        (sum (if (integerp *random-range*) 0 0.0))
        (const t))
    (loop for item in pool
          for min = (random-item-min item)
          for max = (random-item-max item)
          unless (and (or (not min) (numberp min))
                      (or (not max) (numberp max)))
            do (progn (setf const nil)
                      (random-item-min-set! item nil)
                      (random-item-max-set! item nil)
                      (random-item-minmax-set! item (cons min max))))
            (when const
              (setf (pattern-flags obj)
                    (logior +constant-minmax+ (pattern-flags obj))))
            (loop for item in pool
                  for weight = (random-item-weight item)
                  while
                  sum
                  if (numberp weight)
                    do (progn (incf sum weight)
                              (random-item-index-set! item sum))
                  else
                    do (setf sum nil)
                  finally (when (and sum *random-range*)
                            (dolist (item pool)
                              (random-item-index-set!
                               item
                               (*
                                (/ (random-item-index item) sum)
                                *random-range*)))))
                  (when sum
                    (unless *random-range*
                      (setf (random-pattern-range obj) sum))
                    (setf (pattern-flags obj)
                          (logior +constant-weights+
                                  (pattern-flags obj))))
                  (setf (pattern-data obj) (list pool))))

(defmethod canonicalize-pattern-data ((obj random) data parser inits)
  inits
  (flet ((parse-random-item (extern)
           (apply #'(lambda (datum &rest keys)
                      (setf datum (maybeparse parser datum))
                      (loop with orig = keys
                            and args = '()
                            and key
                            and val
                            while (not (null keys))
                            do (setf key (pop keys))
                               (setf
                                val
                                (if
                                 keys
                                 (pop keys)
                                 (error
                                  "Uneven random list: ~s."
                                  orig)))
                               (push val args)
                               (case
                                key
                                ((weight :weight)
                                 (push ':weight args))
                                ((min :min) (push ':min args))
                                ((max :max) (push ':max args))
                                (t
                                 (error
                                  "~s not one of: :weight, :min, :max."
                                  key)))
                            finally (return
                                     (apply
                                      #'make-random-item
                                      :datum
                                      datum
                                      args))))
                      (if (consp extern) extern (list extern)))))
         (let ((intern (mapcar #'parse-random-item data)))
           (values intern
                   (length intern)
                   (not (some (lambda
                               (x)
                               (pattern? (random-item-datum x)))
                              intern))))))

(defmethod reset-period ((obj random))
  (let ((reset (call-next-method)) (flags (pattern-flags obj)))
    (unless (logtest flags +constant-minmax+)
      (let ((b nil))
        (dolist (i (car (pattern-data obj)))
          (setf b (random-item-minmax i))
          (when b
            (random-item-min-set! i (next-1 (car b)))
            (random-item-max-set! i (next-1 (cdr b)))))))
    (unless (logtest flags +constant-weights+)
      (loop with s = (if (integerp *random-range*) 0 0.0)
            for item in (car (pattern-data obj))
            do (incf s (next-1 (random-item-weight item)))
               (random-item-index-set! item s)
            finally (if *random-range*
                        (dolist (i (car (pattern-data obj)))
                          (random-item-index-set! i
                           (* (/ (random-item-index i) s)
                              *random-range*)))
                        (setf (random-pattern-range obj) s))))
      reset))

(defmethod next-in-pattern ((obj random))
  (let* ((pool (pattern-data obj)) (last (cdr pool)))
    (if (and (not (null last))
             (progn (random-item-count-set! last
                     (+ 1 (random-item-count last)))
                    (< (random-item-count last)
                       (random-item-min last))))
        (random-item-datum last)
        (let ((range (random-pattern-range obj))
              (state (pattern-random-state obj))
              (choices (car pool))
              (next nil))
          (setf next
                (loop for item =
                          (loop with index = (random range state)
                                for x in choices
                                when (< index (random-item-index x))
                                return x)
                                unless (and
                                        (random-item-max item)
                                        (=
                                         (random-item-count item)
                                         (random-item-max item)))
                                return item))
                                (unless
                                 (eq next last)
                                 (dolist
                                  (i choices)
                                  (random-item-count-set! i 0)))
                                (rplacd pool next)
                                (random-item-datum next)))))

(defmethod map-pattern-data (fn (obj random))
  (map nil
       #'(lambda (x) (funcall fn (random-item-datum x)))
       (car (pattern-data obj))))

(progn (defclass markov (pattern)
         ((past :initform '() :initarg :past :accessor
           markov-pattern-past)
          (order :accessor markov-pattern-order)
          (produce :initform nil :initarg :produce :accessor
           markov-pattern-produce)))
       (defparameter <markov> (find-class 'markov))
       (finalize-class <markov>)
       (values))

(defmethod pattern-external-inits ((obj markov))
  (flet ((fnc (n)
           `',(append (first n)
                      (list '->)
                      (loop with s = 0
                            for x in (cddr n)
                            for w = (- (second x) s)
                            collect (if
                                     (= w 1)
                                     (car x)
                                     (list (car x) w))
                            do (setf s (second x))))))
         (append (list ':of
                       (cons 'list
                             (loop for x in (cdr (pattern-data obj))
                              collect (fnc x))))
                       (call-next-method)
                       (if (not (markov-pattern-produce obj))
                           (list)
                           (list ':produce
                                 (expand-pattern-value
                                  (markov-pattern-produce obj)))))))

(defmethod canonicalize-pattern-data ((obj markov) data parser inits)
  parser
  (flet ((parse-markov-spec (spec)
           (let ((tail (or (member '-> spec) (member ':-> spec)))
                 (range 0)
                 (inputs '())
                 (parse '())
                 (outputs '()))
             (if tail
                 (progn (setf inputs
                              (loop until (eq spec tail)
                               collect (pop spec)))
                              (setf parse (cdr tail)))
                        (progn (setf inputs '()) (setf parse spec)))
                 (dolist (s parse)
                   (let ((val nil) (pat nil) (wei nil))
                     (if (consp s)
                         (progn (setf val (first s))
                                (setf
                                 wei
                                 (if (null (cdr s)) 1 (second s)))
                                (setf pat wei)
                                (unless
                                 (numberp wei)
                                 (setf wei nil)))
                         (progn (setf val s)
                                (setf wei 1)
                                (setf pat 1)))
                     (if (and wei range)
                         (incf range wei)
                         (setf range nil))
                     (push (list val range pat) outputs)))
                 (cons inputs (cons range (reverse outputs))))))
         (let ((const t))
           (dopairs (a v inits)
            (case a
              ((:produce) (setf const (not (some #'pattern? v))))))
           (loop for s in data
                 for p = (parse-markov-spec s)
                 collect p into lis
                 maximize (length (first p)) into order
                 finally (progn (setf
                                 (markov-pattern-order obj)
                                 order)
                                (return
                                 (values
                                  lis
                                  (length data)
                                  const)))))))

(defmethod initialize-instance :after ((obj markov) &rest args)
  args
  (unless (consp (markov-pattern-past obj))
    (setf (markov-pattern-past obj)
          (make-list (markov-pattern-order obj)
                     :initial-element
                     '*)))
  (values))

(defmethod next-in-pattern ((obj markov))
  (labels ((select-output (range outputs)
             (if (not range)
                 (do ((tail outputs (cdr tail)) (out nil) (sum 0))
                     ((null tail) (select-output sum outputs))
                   (setf out (car tail))
                   (setf sum
                         (+ sum
                            (if (numberp (caddr out))
                                (caddr out)
                                (next-1 (caddr out)))))
                   (rplaca (cdr out) sum))
                 (let ((n (random range)))
                   (loop for o in outputs
                         when (< n (second o)) return (first o)))))
                 (match-past (inputs past)
                   (loop for i in inputs
                         for j in past
                         unless (or (eq i '*) (equal i j) (eq j '*))
                           return nil
                         finally (return t))))
                 (let ((past (markov-pattern-past obj))
                       (data (markov-pattern-produce obj))
                       (item nil))
                   (loop for i in (pattern-data obj)
                         when (or
                               (null past)
                               (match-past (first i) past))
                           do (return
                               (let
                                ((last nil))
                                (setf
                                 item
                                 (select-output (second i) (cddr i)))
                                (unless
                                 (null past)
                                 (if
                                  (null (cdr past))
                                  (rplaca past item)
                                  (progn
                                   (setf last (last past))
                                   (rplaca past item)
                                   (rplacd last past)
                                   (setf
                                    (markov-pattern-past obj)
                                    (cdr past))
                                   (rplacd (cdr last) '()))))
                                item))
                         finally (error
                                  "No outputs for past choices ~s."
                                  (markov-pattern-past obj)))
                         (if data
                             (let
                              ((x (member item data)))
                              (if x (second x) item))
                             item))))

(define-list-struct graph-node id datum to props)

(progn (defclass graph (pattern)
         ((selector :initform
           (funcall #'(lambda nil #'default-graph-node-select))
           :initarg :selector :accessor graph-selector)
          (last :initform nil :initarg :last :accessor graph-last)
          (props :initform '() :initarg :props :accessor graph-props)
          (starting-node-index :initform 0 :initarg
           :starting-node-index :accessor
           graph-starting-node-index)))
       (defparameter <graph> (find-class 'graph))
       (finalize-class <graph>)
       (values))

(defmethod pattern-external-inits ((obj graph))
  (flet ((fnc (n)
           (cons 'list
                 (list (expand-pattern-value (graph-node-datum n))
                       ':id
                       (graph-node-id n)
                       ':to
                       (expand-pattern-value (graph-node-to n))))))
    (append (list ':of
                  (cons 'list
                        (loop for x in (pattern-data obj)
                              collect (fnc x))))
                  (call-next-method)
                  (if (null (graph-props obj))
                      (list)
                      (list ':props
                            (expand-pattern-value
                             (graph-props obj))))
                  (if (eq (graph-selector obj)
                          #'default-graph-node-select)
                      (list)
                      (list ':selector (graph-selector obj))))))

(defmethod initialize-instance :after ((obj graph) &rest args)
  args
  (let ((nodes (pattern-data obj)) (last (graph-last obj)))
    (when last
      (setf (graph-last obj)
            (if (consp last)
                (cons (length last) last)
                (cons last (make-list last :initial-element '*)))))
    (setf (pattern-data obj)
          (cons (elt nodes (graph-starting-node-index obj)) nodes)))
  (values))

(defmethod canonicalize-pattern-data ((obj graph) data parser inits)
  inits
  (flet ((parse-graph-item (extern)
           (unless (consp extern)
             (error "Graph node ~s not list." extern))
           (apply #'(lambda (datum &rest keys)
                      (loop with orig = keys
                            and args = '()
                            and id
                            and to
                            and key
                            and val
                            until (null keys)
                            do (setf key (pop keys))
                               (setf
                                val
                                (if
                                 (null keys)
                                 (error "Bad graph node: ~s." orig)
                                 (pop keys)))
                               (push val args)
                               (case
                                key
                                ((id :id)
                                 (setf id t)
                                 (push ':id args))
                                ((to :to -> :->)
                                 (setf to t)
                                 (push ':to args))
                                ((props :props) (push ':props args))
                                (t
                                 (error
                                  "~s not one of: :id, :to, :props."
                                  key)))
                            finally (progn
                                     (unless
                                      id
                                      (push datum args)
                                      (push ':id args))
                                     to
                                     (return
                                      (apply
                                       #'make-graph-node
                                       :datum
                                       (maybeparse parser datum)
                                       args)))))
                      extern)))
         (let ((intern (mapcar #'parse-graph-item data)))
           (values intern
                   (length intern)
                   (not (some (lambda
                               (x)
                               (pattern? (graph-node-datum x)))
                              intern))))))

(defun default-graph-node-select (obj node lastids)
  (let ((to (graph-node-to node)))
    (if (consp to)
        (if (eq (car to) ':idsel)
            (markov-select obj node to lastids)
            (error ":to not id, :idsel or pattern: ~s." to))
        (next-1 to))))

(defun markov-select (obj node table lastids)
  obj
  (let ((prob
         (loop for tail on (cdr table) by #'cddr
               when (match-ids (car tail) lastids)
                 return (cadr tail))))
         (unless prob
           (error "Node for ~s has no entry for ~s in ~s."
                  (graph-node-id node)
                  lastids
                  table))
         (next-1 prob)))

(defun match-ids (user last)
  (cond ((null user) t)
        ((null last) nil)
        ((consp user)
         (and (match-ids (car user) (car last))
              (match-ids (cdr user) (cdr last))))
        ((eq user last) t)
        ((eq user '*) t)
        ((eq last '*) t)
        (t nil)))

(defmethod next-in-pattern ((obj graph))
  (let* ((last (graph-last obj))
         (graph (pattern-data obj))
         (nodes (cdr graph))
         (this (car graph))
         (next nil))
    (setf next
          (funcall (graph-selector obj)
                   obj
                   this
                   (if last (cdr last))))
    (if next
        (let ((node (find next nodes :key #'graph-node-id)))
          (if node
              (progn (rplaca graph node)
                     (when last
                       (rplacd last
                               (cons
                                (graph-node-id this)
                                (cdr last)))
                       (rplacd (nthcdr (1- (car last)) (cdr last))
                               '())))
              (error "No node for id ~s." next)))
        (error "No next node from ~s." (graph-node-id this)))
    (graph-node-datum this)))

(defmethod map-pattern-data (fn (obj graph))
  (map nil
       #'(lambda (x) (funcall fn (graph-node-datum x)))
       (pattern-data obj)))

(progn (defclass accumulation (pattern)
         ((indices :initform (funcall #'(lambda nil (cons 0 0)))
           :accessor accumulation-indicies)))
       (defparameter <accumulation> (find-class 'accumulation))
       (finalize-class <accumulation>)
       (values))

(defmethod next-in-pattern ((obj accumulation))
  (let ((indices (accumulation-indicies obj)))
    (let ((val (elt (pattern-data obj) (car indices))))
      (if (= (car indices) (cdr indices))
          (progn (rplaca indices 0)
                 (rplacd indices
                         (mod (+ 1 (cdr indices))
                              (pattern-length obj))))
          (rplaca indices (+ 1 (car indices))))
      val)))

(defmethod map-pattern-data (fn (obj accumulation))
  (map nil fn (pattern-data obj)))

(defmethod default-period-length ((obj accumulation))
  (let ((len (pattern-length obj))) (loop for i from 1 to len sum i)))

(progn (defclass funcall (pattern) nil)
       (defparameter <funcall> (find-class 'funcall))
       (finalize-class <funcall>)
       (values))

(defmethod pattern-external-inits ((obj funcall))
  (append (list ':of (expand-pattern-value (car (pattern-data obj))))
          (call-next-method)))

(defmethod default-period-length ((obj funcall)) 1)

(defmethod initialize-instance :after ((obj funcall) &rest args)
  args
  (let ((data (pattern-data obj)))
    (unless (and (consp data) (functionp (car data)))
      (error "Funcall not function: ~s." data))
    (values)))

(defmethod next-in-pattern ((obj funcall))
  (let ((data (pattern-data obj)))
    (when (null (cdr data))
      (let ((vals (funcall (car data))) (len nil))
        (cond ((null vals) (setf vals (list +nad+)))
              ((not (consp vals)) (setf vals (list vals))))
        (setf len (length vals))
        (rplacd data vals)
        (setf (pattern-length obj) len)
        (when (logtest (pattern-flags obj) +default-period+)
          (let ((p (pattern-period obj)))
            (period-count-set! p len)
            (period-length-set! p len)))))
    (pop (cdr data))))

(defmethod map-pattern-data (fn (obj funcall))
  (map nil fn (cdr (pattern-data obj))))

(progn (defclass rotation (cycle)
         ((change :initform 0 :initarg :rotations :accessor
           rotation-change)))
       (defparameter <rotation> (find-class 'rotation))
       (finalize-class <rotation>)
       (values))

(defmethod pattern-external-inits ((obj rotation))
  (append (list ':of
                (cons 'list
                      (loop for x in (car (pattern-data obj))
                            collect (expand-pattern-value x))))
                (if (equal (rotation-change obj) 0)
                    (list)
                    (list ':rotations
                          (expand-pattern-value
                           (rotation-change obj))))))

(defmethod initialize-instance :after ((obj rotation) &rest args)
  args
  (let ((data (pattern-data obj))) (rplacd data (car data))))

(defmethod next-in-pattern ((obj rotation))
  (let ((ring (pattern-data obj)))
    (when (null (cdr ring))
      (let ((change (next-1 (rotation-change obj)))
            (start nil)
            (step nil)
            (width nil)
            (end nil))
        (if (consp change)
            (progn (setf start (pop change))
                   (setf step (if (null change) nil (pop change)))
                   (setf width (if (null change) nil (pop change)))
                   (setf end (if (null change) nil (pop change))))
            (setf start change))
        (unless start (setf start 0))
        (unless step (setf step 1))
        (unless width (setf width 1))
        (unless end (setf end (- (pattern-length obj) width)))
        (rplacd ring
                (rotate-items (car ring) start end step width))))
    (pop (cdr ring))))

(defun rotate-items (items start end step width)
  (loop for i from start below
        end by step
        for a = (elt items i)
        for b = (elt items (+ i width))
        do (setf (elt items i) b)
           (setf (elt items (+ i width)) a))
        items)

(define-list-struct rewrite-node datum id to props)

(define-list-struct rewrite-rule trigger (successors '()) context)

(progn (defclass rewrite (pattern)
         ((table :initform nil :initarg :initially :accessor
           rewrite-table)
          (rules :initform '() :initarg :rules :accessor
           rewrite-rules)
          (generations :initform most-positive-fixnum :initarg
           :generations :accessor rewrite-generations)))
       (defparameter <rewrite> (find-class 'rewrite))
       (finalize-class <rewrite>)
       (values))

(defmethod pattern-external-inits ((obj rewrite))
  (flet ((fnc (n)
           (cons 'list
                 (append (list (expand-pattern-value
                                (rewrite-node-datum n)))
                         (if (eq
                              (rewrite-node-datum n)
                              (rewrite-node-id n))
                             (list)
                             (list ':id (rewrite-node-id n)))
                         (list ':to
                               `',(loop for x in (rewrite-node-to n)
                                   collect (if
                                            (listp x)
                                            (rewrite-node-id x)
                                            x)))))))
         (append (list ':of
                       (cons 'list
                             (hash-fold
                              (lambda (k v l) k (cons (fnc v) l))
                              '()
                              (rewrite-table obj))))
                 (call-next-method))))

(defmethod initialize-instance :after ((obj rewrite) &rest args)
  args
  (let ((table (make-hash-table :size 103 :test #'equal))
        (nodes (pattern-data obj))
        (rules (rewrite-rules obj))
        (preset nil))
    (setf preset
          (or (rewrite-table obj)
              (list (rewrite-node-id (first nodes)))))
    (dolist (n nodes) (setf (gethash (rewrite-node-id n) table) n))
    (dolist (n nodes)
      (let ((x (rewrite-node-to n)))
        (if (pattern? x)
            (progn (rewrite-node-props-set! n (rewrite-node-to n))
                   (rewrite-node-to-set! n nil))
            (progn (rewrite-node-to-set! n
                    (lookup-successors x table))))))
    (let ((count (rewrite-generations obj)))
      (setf (rewrite-generations obj)
            (cons 1
                  (if (> count 1)
                      count
                      (error "Generations: ~s not > 1." count)))))
    (setf nodes
          (loop for id in (if (listp preset) preset (list preset))
                collect (or (gethash id table)
                            (error "Id ~s not in rewrite nodes."
                                   id))))
          (setf (rewrite-table obj) table)
          (setf (pattern-data obj) (cons nodes nodes))
          (unless (null rules)
            (setf (rewrite-rules obj) (parse-rules rules table)))
          (values)))

(defmethod canonicalize-pattern-data ((obj rewrite)
                                      data
                                      parser
                                      inits)
  inits
  (flet ((parse-rewrite-node (extern)
           (let ((datum nil) (keys '()))
             (if (consp extern)
                 (progn (setf datum (car extern))
                        (setf keys (cdr extern)))
                 (setf datum extern))
             (loop with args = '()
                   and id
                   and key
                   and val
                   until (null keys)
                   do (setf key (pop keys))
                      (setf val
                            (if (null keys)
                                (error
                                 "Not a rewrite spec: ~S."
                                 extern)
                                (pop keys)))
                      (push val args)
                      (case key
                        ((id :id) (setf id val) (push ':id args))
                        ((to -> :to :->) (push ':to args))
                        (t
                         (error "~s not one of rewrite keywords: id ->."
                                key)))
                   finally (progn (unless
                                   id
                                   (push datum args)
                                   (push ':id args))
                                  (return
                                   (apply
                                    #'make-rewrite-node
                                    :datum
                                    (maybeparse parser datum)
                                    args)))))))
         (let ((intern (mapcar #'parse-rewrite-node data)))
           (values intern
                   (length intern)
                   (not (some (lambda
                               (x)
                               (pattern? (rewrite-node-datum x)))
                              intern))))))

(defmethod map-pattern-data (fn (obj rewrite))
  (map nil
       #'(lambda (x) (funcall fn (rewrite-node-datum x)))
       (car (pattern-data obj))))

(defun parse-rules (rules table)
  (labels ((getnode (id table rule)
             (or (gethash id table)
                 (error "No node for id ~s in rule ~s." id rule)))
           (getnodes (ids table rule)
             (loop for id in ids collect (getnode id table rule))))
           (loop for rule in rules
                 collect (loop with form = rule
                               and left = t
                               and x
                               while (not (null form))
                               do (setf x (pop form))
                               if (or (eq x '->) (eq x ':->))
                               do (setf left nil)
                               else
                               if left
                               collect x into lh
                               else
                               collect x into rh
                               finally (return
                                        (let
                                         ((len (length lh)))
                                         (unless
                                          (not left)
                                          (error
                                           "Missing -> in rule ~s."
                                           rule))
                                         (cond
                                          ((= len 0)
                                           (error
                                            "Missing left hand side in ~s."
                                            rule))
                                          ((= len 1)
                                           (make-rewrite-rule
                                            :successors
                                            (getnodes rh table rule)
                                            :trigger
                                            (getnode
                                             (if
                                              (consp (car lh))
                                              (caar lh)
                                              (car lh))
                                             table
                                             rule)))
                                          (t
                                           (loop for x in lh
                                            for i from 0
                                            when (consp x)
                                            do (setf
                                                (elt lh i)
                                                (car x))
                                            (return
                                             (make-rewrite-rule
                                              :successors
                                              (getnodes
                                               rh
                                               table
                                               rule)
                                              :trigger
                                              (getnode
                                               (car x)
                                               table
                                               rule)
                                              :context
                                              (cons
                                               (cons i len)
                                               (getnodes
                                                lh
                                                table
                                                rule))))
                                            finally (error
                                                     "No trigger in lh side of ~s."
                                                     rule))))))))))

(defun lookup-successors (successor table)
  (if (consp successor)
      (loop for to in successor
            collect (or (gethash to table)
                        (error "No rewrite node for id ~s." to)))
            (if successor
                (list (or (gethash successor table)
                          (error "No rewrite node for ~s."
                                 successor)))
                nil)))

(defmethod next-in-pattern ((obj rewrite))
  (let ((nodes (pattern-data obj)))
    (when (null (cdr nodes))
      (let ((count (rewrite-generations obj)))
        (if (< (car count) (cdr count))
            (rewrite-generation obj t nil)
            (rplacd nodes (car nodes)))))
    (rewrite-node-datum (pop (cdr nodes)))))

(defun rewrite-generation (obj &optional (new nil) (ids t))
  (let ((data (pattern-data obj)))
    (if (not new)
        (if (not ids)
            (car data)
            (mapcar #'rewrite-node-datum (car data)))
        (let* ((nodes (pattern-data obj))
               (rules (rewrite-rules obj))
               (old (car nodes))
               (new
                (if (null rules)
                    (node-rewrite old (rewrite-table obj))
                    (rule-rewrite old rules))))
          (unless new
            (error "Rewrite: generation #~D is empty!"
                   (+ (car (rewrite-generations obj)) 1)))
          (progn (rplacd nodes new) (rplaca nodes new))
          (if (not ids)
              (car nodes)
              (mapcar #'rewrite-node-datum (car data)))))))

(defun node-rewrite (gen table)
  (loop for node in gen
        for next =
            (let ((to (rewrite-node-to node)))
              (if to
                  (copy-list to)
                  (lookup-successors
                   (next-1 (rewrite-node-props node)) table)))
        nconc next))

(defun rule-rewrite (generation rules)
  (loop with context
        and length
        for index from 0
        for node in generation
        append (loop for rule in rules
                     do (when (eq node (rewrite-rule-trigger rule))
                          (setf context (rewrite-rule-context rule))
                          (if context
                              (let*
                               ((seq (cdr context))
                                (beg (- index (caar context)))
                                (end (+ beg (cdar context))))
                               (when
                                (and
                                 (<=
                                  0
                                  beg
                                  end
                                  (or
                                   length
                                   (progn
                                    (setf length (length generation))
                                    length)))
                                 (not
                                  (mismatch
                                   seq
                                   generation
                                   :start2
                                   beg
                                   :end2
                                   end
                                   :test
                                   #'(lambda
                                      (a b)
                                      (or (eq a '*) (eq a b))))))
                                (return
                                 (rewrite-rule-successors rule))))
                              (return
                               (rewrite-rule-successors rule))))
                     finally (return (list)))))

(defmacro %range-stepping? (flags) `(logtest ,flags +range-stepping+))

(defmacro %range-unbounded? (flags)
  `(logtest ,flags +range-unbounded+))

(defmacro %range-initially? (flags)
  `(logtest ,flags +range-initially+))

(defmacro %range-dynamic? (flags) `(logtest ,flags +range-dynamic+))

(defmacro %range-random? (flags) `(logtest ,flags +range-random+))

(progn (defclass range (pattern)
         ((from :initform nil :initarg :from :initarg :initially
           :accessor range-from)
          (to :initform nil :initarg :to :initarg :below :initarg
           :pickto :accessor range-to)
          (downto :initform nil :initarg :downto :initarg :above
           :accessor range-downto)
          (by :initform nil :initarg :by :initarg :stepping :accessor
           range-by)
          (incf :initform nil :accessor range-incf)
          (test :initform nil :accessor range-test)))
       (defparameter <range> (find-class 'range))
       (finalize-class <range>)
       (values))

(defmethod pattern-external-inits ((obj range))
  (let ((bits (pattern-flags obj)))
    (append (list (if (%range-initially? bits) ':initially ':from)
                  (expand-pattern-value (range-from obj)))
            (if (range-to obj)
                (list (if (%range-random? bits)
                          ':pickto
                          (if (funcall (range-test obj) 2 0 2)
                              ':below
                              ':to))
                      (expand-pattern-value (range-to obj)))
                (if (range-downto obj)
                    (list (if (funcall (range-test obj) 0 0 2)
                              ':above
                              :downto)
                          (expand-pattern-value (range-downto obj)))
                    (list)))
            (list (if (%range-stepping? bits) ':stepping ':by)
                  (expand-pattern-value (range-by obj)))
            (call-next-method))))

(defmethod initialize-instance :after ((obj range) &rest args)
  args
  (let* ((raw (pattern-data obj))
         (data (car raw))
         (init (cadr raw))
         (flag nil)
         (test nil)
         (bits nil))
    (setf (pattern-data obj) data)
    (setf (range-from obj) (elt init 0))
    (setf (range-to obj) (elt init 1))
    (setf (range-downto obj) (elt init 2))
    (setf (range-by obj) (elt init 3))
    (setf (range-incf obj) (elt init 4))
    (setf flag (elt init 5))
    (setf bits (elt init 6))
    (case flag
      ((1) (setf test #'(lambda (x min max) min (> x max))))
      ((2) (setf test #'(lambda (x min max) min (>= x max))))
      ((4) (setf test #'(lambda (x min max) max (< x min))))
      ((8) (setf test #'(lambda (x min max) max (<= x min))))
      ((5)
       (setf test #'(lambda (x min max) (or (< x min) (> x max)))))
      ((6)
       (setf test #'(lambda (x min max) (or (< x min) (>= x max)))))
      ((9)
       (setf test #'(lambda (x min max) (or (<= x min) (> x max)))))
      ((10)
       (setf test #'(lambda (x min max) (or (<= x min) (>= x max)))))
      ((16) nil)
      ((0) (setf bits (logior bits +range-unbounded+)))
      (t (error "Not a range specification: ~s." args)))
    (when (and (%range-initially? bits)
               (not (%range-unbounded? bits)))
      (error ":initially excludes lower or upper bound."))
    (when (eq (period-length (pattern-period obj))
              most-positive-fixnum)
      (setf bits (logior bits +range-dynamic+)))
    (setf (pattern-flags obj) (logior (pattern-flags obj) bits))
    (setf (range-test obj) test)))

(defmethod canonicalize-pattern-data ((obj range) data parser inits)
  data
  parser
  (let ((from 0)
        (to nil)
        (downto nil)
        (by 1)
        (incf #'+)
        (flag 0)
        (bits 0)
        (const? t))
    (dopairs (a v inits)
     (case a
       ((:from) (setf from v))
       ((:initially) (setf from v)
        (setf bits (logior bits +range-initially+)))
       ((:to) (setf to v) (setf flag (logior flag 1))
        (setf incf #'+))
       ((:below) (setf to v) (setf flag (logior flag 2))
        (setf incf #'+))
       ((:downto) (setf downto v) (setf flag (logior flag 4))
        (setf incf #'-))
       ((:above) (setf downto v) (setf flag (logior flag 8))
        (setf incf #'-))
       ((:pickto) (setf to v)
        (setf bits (logior bits +range-random+))
        (setf flag (logior flag 16)) (setf incf #'between))
       ((:by) (setf by v))
       ((:stepping) (setf by v)
        (setf bits (logior bits +range-stepping+)))))
    (if (or (pattern? from)
            (pattern? to)
            (pattern? downto)
            (pattern? by))
        (setf const? nil))
    (values (if const?
                (list (list by from nil downto to)
                      (list from to downto by incf flag bits))
                (list (list nil nil nil nil nil)
                      (list from to downto by incf flag bits)))
            (if (or to downto) most-positive-fixnum 1)
            const?)))

(defun reset-range? (data test)
  (or (not (third data)) (and test (apply test (cddr data)))))

(defmethod next-in-pattern ((obj range))
  (let ((bits (pattern-flags obj))
        (data (pattern-data obj))
        (test (range-test obj))
        (from nil))
    (when (reset-range? data test)
      (if (logtest bits +constant-data+)
          (progn (unless (and (%range-initially? bits) (third data))
                   (rplaca (cddr data) (cadr data))))
          (progn (unless (%range-stepping? bits)
                   (rplaca data (next-1 (range-by obj))))
                 (rplaca (cdr data) (next-1 (range-from obj)))
                 (unless (and (%range-initially? bits) (third data))
                   (rplaca (cddr data) (cadr data)))
                 (rplaca (cdddr data) (next-1 (range-downto obj)))
                 (rplaca (cddddr data) (next-1 (range-to obj))))))
    (if (%range-random? bits)
        (progn (setf from
                     (funcall (range-incf obj)
                              (second data)
                              (car (cddddr data))))
               (rplaca (cddr data) from))
        (progn (setf from (third data))
               (rplaca (cddr data)
                       (funcall (range-incf obj)
                                from
                                (if
                                 (%range-stepping? bits)
                                 (next-1 (range-by obj))
                                 (first data))))))
    (if (and (%range-dynamic? bits) (reset-range? data test))
        (period-count-set! (pattern-period obj) 1))
    from))

(defmethod reset-period ((obj range))
  (let ((val (call-next-method)))
    (let ((bits (pattern-flags obj)))
      (if (and (%range-unbounded? bits)
               (not (%range-initially? bits)))
          (rplaca (cddr (pattern-data obj)) nil)))
    val))

(progn (defclass transposer (container)
         ((of :initarg :of :accessor transposer-of)
          (by :accessor transposer-by :initarg :by :initarg :stepping
           :initarg :on)
          (form :accessor transposer-form :initform nil :initarg
           :form)
          (mod :accessor transposer-mod :initform nil :initarg :mod)
          (scale :accessor transposer-scale :initform *scale*
           :initarg :scale)))
       (defparameter <transposer> (find-class 'transposer))
       (finalize-class <transposer>)
       (values))

(defmethod pattern? ((obj transposer)) obj)

(defmethod make-load-form ((obj transposer))
  `(make-instance
     <transposer>
     ,@(append (list ':of (expand-pattern-value (transposer-of obj)))
               (let ((by (transposer-by obj)))
                 (if (third by)
                     (list ':stepping
                           (expand-pattern-value (second by)))
                     (list ':by
                           (if (second by)
                               (expand-pattern-value (second by))
                               (first by)))))
               (if (not (transposer-form obj))
                   (list)
                   (list ':form
                         (expand-pattern-value
                          (transposer-form obj))))
               (if (not (transposer-mod obj))
                   (list)
                   (list ':mod
                         (expand-pattern-value
                          (transposer-mod obj))))
               (if (eq (transposer-scale obj) *scale*)
                   (list)
                   (list ':scale
                         `(find-object
                           ',(object-name
                              (transposer-scale obj))))))))

(defmethod initialize-instance :after ((obj transposer) &rest args)
  args
  (let ((data nil) (stepping? nil))
    (dopairs (s v args)
     (case s
       ((:stepping)
        (when data
          (error "Duplicate ':stepping', ':by' or ':on' in: ~s"
                 args))
        (setf stepping? t) (setf data v))
       ((:by :on)
        (when data
          (error "Duplicate ':stepping', ':by' or ':on' in: ~s"
                 args))
        (setf data v))))
    (unless data
      (error "Missing ':stepping', ':by' or ':on' in: ~s" args))
    (setf (transposer-by obj)
          (if stepping?
              (list nil data t)
              (if (pattern? data)
                  (list nil data nil)
                  (list data nil nil))))
    (unless (slot-boundp obj 'of) (error "Missing ':of' data."))
    (setf data (transposer-form obj))
    (when data
      (setf (transposer-form obj)
            (if (and data (symbolp data))
                (list data nil)
                (list nil data))))))

(defmethod eop? ((obj transposer)) (eop? (transposer-of obj)))

(defmethod next-1 ((obj transposer))
  (let* ((by (transposer-by obj))
         (step? (third by))
         (scale (transposer-scale obj))
         (form (transposer-form obj))
         (data nil)
         (flag nil))
    (when (not (first by))
      (rplaca by (next-1 (second by)))
      (when (and form (second form))
        (rplaca form (next-1 (second form)))))
    (setf data (next-1 (transposer-of obj)))
    (setf flag (eop? (transposer-of obj)))
    (setf data (transpose data (first by) scale))
    (when form
      (case (first form)
        ((r :r retrograde :retrograde) (setf data (reverse data)))
        ((p :p prime :prime))
        ((i :i inversion :inversion) (setf data (invert data)))
        ((ri :ri retrograde-inversion :retrograde-inversion)
         (setf data (reverse (invert data))))
        (t (error "Not a transposition form: ~s." form))))
    (when (transposer-mod obj)
      (setf data
            (scale-mod data (transposer-mod obj) :offset (first data)
             :in (transposer-scale obj))))
    (if (and (or flag step?) (second by)) (rplaca by nil))
    data))

(progn (defclass chord (pattern) nil)
       (defparameter <chord> (find-class 'chord))
       (finalize-class <chord>)
       (values))

(defmethod pattern-external-inits ((obj chord))
  (append (list ':of
                (if (null (cdr (pattern-data obj)))
                    (expand-pattern-value obj)
                    (cons 'list
                          (loop for x in (pattern-data obj)
                                collect (expand-pattern-value x)))))
                (call-next-method)))

(defmethod canonicalize-pattern-data ((pat chord) data parser inits)
  inits
  (if parser
      (loop for datum in data
            count datum into length
            count (pattern? datum) into streams
            collect (maybeparse parser datum) into list
            finally (return (values list 1 (= streams 0))))
            (values data 1 (not (some #'pattern? data)))))

(defmethod default-period-length ((obj chord)) 1)

(defmethod next-in-pattern ((obj chord))
  (let ((data (pattern-data obj)))
    (if (logtest (pattern-flags obj) +constant-data+)
        data
        (if (null (cdr data))
            (next (first data) t)
            (apply #'append
                   (mapcar #'(lambda (x) (next x t)) data))))))

(progn (defclass pval () ((thunk :initarg :of :accessor pval-thunk)))
       (defparameter <pval> (find-class 'pval))
       (finalize-class <pval>)
       (values))

(defmethod make-load-form ((obj pval)) `(pval ,(pval-thunk obj)))

(defmethod pattern? ((obj pval)) obj)

(defmacro pval (expr) `(make-instance <pval> :of (lambda nil ,expr)))

(defmethod next-1 ((obj pval)) (funcall (pval-thunk obj)))

(progn (defclass join (pattern)
         ((format :accessor
                  join-format
                  :initarg
                  :format
                  :initform
                  nil)
          (cache :accessor join-cache :initform nil)))
       (defparameter <join> (find-class 'join))
       (finalize-class <join>)
       (values))

(defmethod pattern-external-inits ((obj join))
  (append (list ':of
                (cons 'list
                      (loop for x in (pattern-data obj)
                            collect (expand-pattern-value x))))
                (list ':format
                      (expand-pattern-value (join-format obj)))
                (call-next-method)))

(defmethod initialize-instance :after ((obj join) &rest args)
  args
  (let* ((per (pattern-period obj))
         (len (length (pattern-data obj)))
         (data (pattern-data obj))
         (fmat (join-format obj))
         (ppat nil))
    (period-stream-set! per (period-default per))
    (cond ((not fmat)
           (setf fmat (make-list len :initial-element ':eop))
           (setf (join-format obj) fmat))
          ((not (listp fmat))
           (error "Expected :format list but got ~s instead." fmat))
          ((not (= (length fmat) len))
           (error ":format list has ~s elements but length of data is ~s."
                  (length fmat)
                  len)))
    (dotimes (i len)
      (case (elt fmat i)
        ((:eop)
         (if (pattern? (elt data i)) nil (setf (elt fmat i) nil)))
        ((t)
         (if (pattern? (elt data i))
             (setf (elt fmat i) ':each)
             (setf (elt fmat i) nil)))
        ((nil)
         (if (pattern? (elt data i))
             (progn (setf ppat t) (setf (elt fmat i) ':once))
             (setf (elt fmat i) nil)))
        (t
         (error "Bad :format value ~s: not :eop, ~s or ~s"
                (elt fmat i)
                t
                nil))))
    (setf (join-format obj) fmat)
    (when ppat
      (setf ppat (make-list len :initial-element nil))
      (dotimes (i len)
        (if (eq (elt fmat i) ':once)
            (progn (setf (elt ppat i) (elt data i))
                   (setf (elt data i) nil))))
      (setf (join-cache obj) ppat))
    (values)))

(defmethod canonicalize-pattern-data ((obj join) data parser inits)
  inits
  (let ((subs (not (some #'pattern? data))))
    (if parser
        (loop for datum in data
              count datum into length
              collect (maybeparse parser datum) into list
              finally (return (values
                               list
                               (if subs 1 most-positive-fixnum)
                               (not subs))))
              (values data
                      (if subs 1 most-positive-fixnum)
                      (not subs)))))

(defmethod reset-period ((obj join))
  (let ((val (call-next-method)))
    (let ((c (join-cache obj)))
      (when c
        (let ((d (pattern-data obj)) (i 0))
          (dolist (x c)
            (if x (setf (elt d i) (next-1 x)))
            (setf i (+ i 1))))))
    val))

(defun join-eop? (data fmat)
  (do ((end? t))
      ((null data) end?)
    (if (eq (car fmat) ':eop)
        (if (eop? (car data)) nil (setf end? nil)))
    (setf data (cdr data))
    (setf fmat (cdr fmat))))

(defmethod next-in-pattern ((obj join))
  (let ((next (list nil))
        (data (pattern-data obj))
        (fmat (join-format obj)))
    (do ((l1 data (cdr l1)) (l2 fmat (cdr l2)) (l3 next (cdr l3)))
        ((null l1) nil)
      (if (not (car l2))
          (rplacd l3 (list (car l1)))
          (rplacd l3 (list (next-1 (car l1))))))
    (when (join-eop? data fmat)
      (period-count-set! (pattern-period obj) 1))
    (cdr next)))

(progn (defclass copier (pattern)
         ((source :accessor copier-source)
          (repfor :accessor copier-repfor :initform nil :initarg
           :repeat-for)))
       (defparameter <copier> (find-class 'copier))
       (finalize-class <copier>)
       (values))

(defmethod pattern-external-inits ((obj copier))
  (append (list ':of (expand-pattern-value (copier-source obj)))
          (call-next-method)))

(defmethod initialize-instance :after ((obj copier) &rest args)
  args
  (let ((data (pattern-data obj)))
    (setf (copier-source obj) (car data))
    (setf (pattern-data obj) (list))
    (values)))

(defmethod next-in-pattern ((obj copier))
  (let ((data (pattern-data obj)))
    (if (null data)
        (let* ((per (pattern-period obj))
               (res (next (copier-source obj) t))
               (len (length res))
               (for (period-length per))
               (rep (copier-repfor obj)))
          (if rep
              (progn (setf for (next rep))
                     (period-length-set! per len)
                     (period-count-set! per len))
              (period-count-set! per (* len for)))
          (let ((sav res))
            (dotimes (i (- for 1))
              (setf res (append res (copy-list sav)))))
          (setf (pattern-data obj) (cdr res))
          (car res))
        (progn (setf (pattern-data obj) (cdr data)) (car data)))))
