snd 17.1-1 / usr / share / snd / CM_patterns.scm

;;; **********************************************************************
;;; Copyright (c) 2008, 2009 Rick Taube.
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the Lisp Lesser Gnu Public License. The text of
;;; this agreement is available at http://www.cliki.net/LLGPL            
;;; **********************************************************************

;;; [2015-06-11, AV]: adapting to stand-alone loading in a running 's7' (i.e. snd), start
;;; snd, then load this file

(require r7rs.scm)

;; some functions collect from various places (s7.scm, utilities.scm)

(define-macro (with-optkeys spec . body)
  ((lambda (user rawspec body)
	   
     (define (string->keyword str) (symbol->keyword (string->symbol str)))
	   
     (define (key-parse-clause info mode args argn user)
       ;; return a cond clause that parses one keyword. info for each
       ;; var is: (<got> <var> <val>)
       (let* ((got (car info))
	      (var (cadr info))
	      (key (string->keyword (symbol->string var))))
	 `((eq? (car ,args) ,key )
	   (if ,got (error "duplicate keyword: ~S" , key))
	   (set! ,var (if (null? (cdr ,args))
			  (error "missing value for keyword: ~S" 
				 , user)
			  (cadr ,args)))
	   (set! ,got #t)   ; mark that we have a value for this param
	   (set! ,mode #t)  ; mark that we are now parsing keywords
	   (set! ,argn (+ ,argn 1))
	   (set! ,args (cddr ,args)))))
	   
     (define (pos-parse-clause info mode args argn I)
       ;; return a cond clause that parses one positional. info for
       ;; each var is: (<got> <var> <val>)
       (let ((got (car info))
	     (var (cadr info)))
	 `((= ,argn ,I)
	   (set! ,var (car ,args))
	   (set! ,got #t)   ; mark that we have a value for this param
	   (set! ,argn (+ ,argn 1))
	   (set! ,args (cdr ,args)))))
	   
     (let* ((otherkeys? (member '&allow-other-keys rawspec))
	    ;; remove &allow-other-keys from spec
	    (spec (if otherkeys? (reverse (cdr (reverse rawspec))) rawspec))
	    (data (map (lambda (v)
			 ;; for each optkey variable v return a list
			 ;; (<got> <var> <val>) where the <got>
			 ;; variable indicates that <var> has been
			 ;; set, <var> is the optkey variable itself
			 ;; and <val> is its default value
			 (if (pair? v)
			     (cons (gensym (symbol->string (car v))) v)
			     (list (gensym (symbol->string v)) v #f)))
		       spec))
	    (args (gensym "args"))	; holds arg data as its parsed
	    (argn (gensym "argn"))
	    (SIZE (length data))
	    (mode (gensym "keyp"))	; true if parsing keywords
	    ;; keyc are cond clauses that parse valid keyword
	    (keyc (map (lambda (d) (key-parse-clause d mode args argn user))
		       data))
	    (posc (let lup ((tail data) (I 0))
		    (if (null? tail) (list)
			(cons (pos-parse-clause (car tail) mode args argn I)
			      (lup (cdr tail) (+ I 1))))))
	    (bindings (map cdr data))	; optkey variable bindings
	    )
	     
       (if otherkeys?
	   (set! bindings (cons '(&allow-other-keys (list)) bindings)))
	     
       `(let* ,bindings ; bind all the optkey variables with default values
	  ;; bind status and parsing vars
	  (let ,(append (map (lambda (i) (list (car i) #f)) data)
			`((,args ,user)
			  (,argn 0)
			  (,mode #f)))
	    ;; iterate arglist and set opt/key values
	    (do ()
		((null? ,args) #f)
	      (cond 
	       ;; add valid keyword clauses first
	       ,@ keyc
		  ;; a keyword in (car args) is now either added to
		  ;; &allow-other-keys or an error
	       , (if otherkeys?
		     `((keyword? (car ,args))
		       (if (not (pair? (cdr ,args)))
			   (error "missing value for keyword ~S" (car ,args)))
		       (set! &allow-other-keys (append &allow-other-keys
						       (list (car ,args)
							     (cadr ,args))))
		       (set! ,mode #t)	; parsing keys now...
		       (set! ,args (cddr ,args)) )
		     `((keyword? (car ,args)) ;(and ,mode (keyword? (car ,args)))
		       (error "invalid keyword: ~S" (car ,args)) )
		     )
		 ;; positional clauses illegal if keywords have happened
	       (,mode (error "positional after keywords: ~S" (car ,args)))
	       ;; too many value specified
	       ((not (< ,argn ,SIZE)) (error "too many args: ~S" , args))
	       ;; add the valid positional clauses
	       ,@ posc
	       ))
	    ,@ body))
       ))
   (car spec)
   (cdr spec)
   body
   ))

;;; based on define-record-type from snd/r7rs.scm.  Works with srfi-17?

(define-macro (define-record typename . fields)
  `(define-record-type ,typename
     (,(symbol (format #f "make-~A" typename)) ,@fields)
     ,(symbol (format #f "~A?" typename))
     ,@(map (lambda (x) `(,x
			  ,(symbol (format #f "~A-~A" typename x))
			  ,(symbol (format #f "~A-~A-set!" typename x))))
	    fields)))


;; grabbed from s7.scm:

(define (string->keyword s)
  (make-keyword s))

(define (logtest a b)
  (not (zero? (logand a b))))

(define sort sort!)

;; grabbed from utilities.scm:

(define (list-index p l)
  (do ((tail l (cdr tail))
       (i 0  (+ i 1))
       (f #f))
      ((or f (null? tail ))
       f)
    (if ( p (car tail)) (set! f i))))

;; (autoload 'with-optkeys "scm/utilities.scm") ; + quite some others
;; (autoload 'string->keyword "scm/s7.scm")

;; scm/toolboox.scm:

(define (decimals value places)
  (let ((n (expt 10.0 places)))
    (if (list? value)
	(map (lambda (v) (/ (round (* v n)) n)) value)
	(/ (round (* value n)) n))))

;;;
;;; patterns using structs instead of classes.
;;; requires with-optkeys, arithmetic-test, list-set, tb:rani tb:ranf
;;;
;;;
;;; [AV, 2015-06-11]: various ffi_ random functions are substituded
;;; with schemes standard random


(define-constant +constant-data+    (ash 1 0)) ; avoid hair when possible
(define-constant +default-period+   (ash 1 1)) ; no period specified
(define-constant +constant-weights+ (ash 1 2)) ; avoid random index recalc
(define-constant +count-periods+    (ash 1 3)) ; period counts subperiods
(define-constant +count-values+     (ash 1 4)) ; period counts values
(define-constant +depth-first+      (ash 1 5)) ; pattern moves on eop
(define-constant +breadth-first+    (ash 1 6)) ; pattern moves each time

(define-constant +nad+ '#:nad)         ; "not a datum" marker
(define-constant +eop+ '#:eop)         ; "end of period" marker
(define-constant +eod+ '#:eod)         ; "end of data" marker

;;; the period struct holds information for period calculation.  count
;;; is number of reads remaining in current period. when count=0 the
;;; period is reinitialized. length is maximum count of the period,
;;; either a number or #t if dynamic length. if stream is not #f a new
;;; length will be read from it each time the period is initialized.
;;; omit is the number of times this stream is skipped in its parent's
;;; pattern, if dynamic. Reps keeps track of the number of
;;; periods. Max is the max number of periods allowed, after which the
;;; pattern always returns +eod+

(define-record period count length stream default omit reps )

(define (pperiod obj )
  (list 'period
	(period-count obj) (period-length obj) (period-stream obj)
	(period-default obj) (period-omit obj) (period-reps obj)
	))

(define-record pattern flags data length datum period value state 
	       repeat returning counting traversing next mapr cache)

(define (ppattern obj )
  (list 'pattern
	#:flags (pattern-flags obj)
	#:data (pattern-data obj)
	#:length (pattern-length obj)
	#:datum (pattern-datum obj)
	#:period (pperiod (pattern-period obj))
	#:value (pattern-value obj)
	#:state (pattern-state obj)
	#:repeat (pattern-repeat obj)
	#:returning (pattern-returning obj)
	#:cache (pattern-cache obj)
	))

(define (%alloc-pattern)
  ;; flags data length datum period value state limit returning counting traversing next mapr cache
  (make-pattern 0 (list) #f +nad+ #f +nad+ +nad+ most-positive-fixnum #f #:periods #:depth-first
		#f #f #f))

(define (initialize-pattern obj data for rep flags len dper getr mapr)
  (pattern-data-set! obj data)
  (pattern-length-set! obj len)
  (pattern-mapr-set! obj mapr)
  (pattern-next-set! obj getr)
  ;; map data to see if it is constant data or has subpatterns
  (let ((con? #t))
    (map-pattern-data (lambda (x) (if (pattern? x) (set! con? #f))) 
		      obj)
    (if con? (set! flags (logior flags +constant-data+))))
  ;; parse counting option
  (let ((counting (pattern-counting obj)))
    (case counting
      ((#:periods )
       (set! flags (logior flags +count-periods+)))
      ((#:values )     
       (set! flags (logior flags +count-values+)))
      (else
       (error "illegal counting value ~S" counting))))
  ;; parse traversing option
  (let ((traversing (pattern-traversing obj)))
    (case traversing
      ((#:depth-first ) 
       (set! flags (logior flags +depth-first+)))
      ((#:breadth-first )
       (set! flags (logior flags +breadth-first+)))
      (else
       (error "illegal traversing value ~S" traversing))))
  ;; if constant data and counting subperiods, switch to counting
  ;; values instead since its the same thing and we can avoid
  ;; resetting subperiods if period length is nevertheless expressed
  ;; dynamically.
  (cond ((logtest flags +count-values+)
	 (set! flags (logand flags (lognot +count-periods+))))
	(else
	 (if (logtest flags +constant-data+)
	     (set! flags (logior 
			  (logand 
			   flags (lognot +count-periods+))
			  +count-values+))
	     (set! flags (logior flags +count-periods+)))))
  (pattern-repeat-set! obj (if (and (number? rep) (> rep 0))
			       rep most-positive-fixnum))
  (let ((per (or for dper)))
    ;; period not specified so mark that we are using default period
    (when (not for)
      (set! flags (logior flags +default-period+)))
    (pattern-period-set! obj
			 (if (or (number? per)
				 (eqv? per #t))
			     ;;           count len src dper omit reps
			     (make-period 0     per #f  dper 0    0)
			     ;;           count len src dper omit reps 
			     (make-period 0     #f  per dper 0    0))))
  (pattern-flags-set! obj flags)
  (values))

;;;
;;; Predicates for testing end-of-period and end-of-data.
;;;

(define (eop? x)
  (if (pattern? x)
      (eop? (pattern-state x))
      (eqv? x +eop+)))

(define (eod? x)
  (if (pattern? x)
      (eod? (pattern-value x))
      (eqv? x +eod+)))

;;;
;;; next returns the next value read from the object.  this around
;;; method implements the basic behavior of patterns.  it first checks
;;; the stream's period length and calls reset-period if at end. if
;;; the next period length is 0 it immediately returns +nad+, which
;;; causes a superior stream (if any) to skip over the current stream
;;; as it increments its pattern.  otherwise, the method then
;;; increments the streams pattern until it yields a datum that is not
;;; +nad+ and that call-next-method does not return +nad+ from. if the
;;; stream's data is known to contain only constant values, ie no
;;; substreams, the testing loop is skipped. once call-next-method
;;; returns a value (not +nad+), the period and pattern of the stream
;;; are incremented according to their mode. for period incrementing,
;;; +count-periods+ increments the period count only on +eop+, and
;;; +count-values+ increments the period count every time. for pattern
;;; incrementing, +depth-first+ increments the pattern only on +eop+,
;;; and +breadth-first+ increments the pattern every time.
;;;

(define (next obj . args)
  (let ((num (if (null? args) #f (car args))))
    (if num
      (if (number? num )
        (let ((l (list #f)))
          (do ((i 0 (+ 1 i))
               (e l (cdr e)))
              ((>= i num)
               (cdr l))
            (set-cdr! e (list (next-1 obj)))))
        (if (pattern? obj)
          (let ((l (list #f)))
            (do ((n (next-1 obj) )
                 (e l (cdr e))
                 (f #f))
                ((or (eqv? n +eod+) f)
                 (cdr l))
              (set-cdr! e (list n))
              (if (eop? obj)
                (set! f #t)
                (set! n (next-1 obj))))) 
          (list obj)))
      (next-1 obj))))

(define (next-1 obj)
  (cond ((pattern? obj)
	 (let ((period (pattern-period obj))
	       (nomore #f))
	   ;; reset period, return
	   (when (= (period-count period) 0)
		 (when (>= (period-reps period)
			   (pattern-repeat obj))
		       (pattern-value-set! obj +eod+)
		       (pattern-state-set! obj +eop+)
		       (set! nomore +eod+))
		 (when (and (not nomore)
			    (= (reset-period obj) 0))
		       (set! nomore +nad+)
		       (pattern-value-set! obj +nad+)
		       (pattern-state-set! obj +eop+)))
	   (if nomore
	       nomore
	       (let ((flags (pattern-flags obj))
		     (retfn (pattern-returning obj))
		     (value #f)
		     (state #f))
		 ;; increment datum until not +nad+
		 (if (logtest flags +constant-data+)
		     (begin
		       (pattern-datum-set! obj (next-in-pattern obj))
		       (set! value (next-1 (pattern-datum obj)))
		       (set! state +eop+)
		       ;;(print (list #:consant!))
		       )
		     (do ((dyn? (and (logtest flags +count-periods+)
				     (eqv? (period-length period) #t)))
			  (stop #f))
			 (stop #f)
		       ;; increment over 0 length substreams
		       (do ()
			   ((not (eqv? (pattern-datum obj) +nad+)) #f)
			 (pattern-datum-set! obj
					     (if dyn?
						 (skip-datum? (next-in-pattern obj))
						 (next-in-pattern obj))))
		       (set! value (next-1 (pattern-datum obj)))
		       (if (pattern? (pattern-datum obj))
			   (set! state (pattern-state (pattern-datum obj)))
			   (set! state +eop+))
		       ;; increment over +nad+ values returned by obj.
		       (if (eqv? value +nad+)
			   (pattern-datum-set! obj value)
			   (set! stop #t ))) )
		 ;; increment period and pattern as appropriate.
		 (cond ((eqv? state +eop+)
			;;(print (list #:state-eop!))
			(period-count-set! period (- (period-count period) 1))
			(pattern-datum-set! obj +nad+)
			(set! state #f))
		       (else
			(if (logtest flags +breadth-first+)
			    (pattern-datum-set! obj +nad+))
			(if (logtest flags +count-values+)
			    (period-count-set! period
					       (- (period-count period) 1)))))
		 ;;(print (list #:period-count (period-count period)))
		 (if (= (period-count period) 0)
		     (begin (set! state +eop+)
			    (period-reps-set! period
					      (+ 1 (period-reps period))))
		     (set! state state))
		 
		 (if retfn
		     (set! value ( retfn value)));; thunk
		 
		 (pattern-state-set! obj state)
		 (pattern-value-set! obj value)
		 value))))
	((procedure? obj)
	 (obj )	 )

	(else
	 obj)))

(define (next-in-pattern obj)
  ( (pattern-next obj) obj)
  )

(define (map-pattern-data fn obj)
  ( (pattern-mapr obj) fn obj)
  )

;;;
;;; skip-datum? returns +nad+ if the current stream should be skipped
;;; in the pattern. this only happens if we have dynamic periodicity
;;; and the datum had a 0 length period when it was encountered by
;;; reset-period.
;;;

(define (skip-datum? obj)
  (if (not (pattern? obj))
      obj
      (let ((period (pattern-period obj)))
	(if (> (period-omit period) 0)
	    (begin (period-omit-set! period
				     (- (period-omit period) 1))
		   +nad+)
	    obj))))

;;;
;;; reset-period sets and returns the length of the next
;;; period. period length of constant datum is always 1.
;;;

(define (reset-period obj)
  (if (not (pattern? obj)) 1
      (let ((period (pattern-period obj))
	    (dyn #f)
	    (len #f))
	
	;; if period is supplied as a stream get next length via item
	(when (period-stream period)
	  (period-length-set! period
			      (next-1 (period-stream period))))
	(set! dyn (eqv? (period-length period) #t))
	(set! len
	      (if dyn
		  (period-default period)
		  (period-length period)))
	;; if we have dynamic period length we adjust next period
	;; length for the number of 0 subperiods that this period will
	;; encounter.  in order for this to work, all substream
	;; periods must be reset now, at the same that the super
	;; stream is reset. we can only do this if we know that all
	;; subperiods are currently at end of period, ie if we are
	;; counting by subperiods. if so, then by definition all the
	;; substreams must be at end-of-period or we couldn't have
	;; gotton here in the first place. after resetting substream
	;; period lengths we decrement our current stream's period
	;; length by the number of zero periods found.
	(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)))
		 (set! zeros (+ zeros 1))
		 ))
	     obj)
	    (when (> zeros 0)
	      (set! len (max (- len zeros) 0)))))
	(period-count-set! period len)

	len)))

;;;
;;; pattern implementations.
;;;
;;; cycle continously loops over its data. the data are held in a list
;;; of the form: (data . data). successive elements are popped from
;;; the cdr and when the cdr is null it's reset to the car.
;;;

(define (make-cycle data . args)
  (unless (pair? data) (set! data (list data)))
  (with-optkeys (args for limit)
    (let ((obj (%alloc-pattern))
	  (flags 0)
	  (len (length data)))
      (initialize-pattern obj (cons data data) for limit
			  flags len len next-in-cycle
			  (lambda (fn obj) 
			    (for-each fn (car (pattern-data obj)))))
      obj)))

(define (next-in-cycle obj)
  (let ((data (pattern-data obj)))
    (if (null? (cdr data))
	(set-cdr! data (car data)))
    (let ((x (cadr data)))
      (set-cdr! data (cddr data))
      x)))

; (define aaa (make-cycle (list 1 2 3)))
; (next aaa #t)
; (define aaa (make-cycle (list 1 2 3) :for 2))
; (next aaa #t)
; (define aaa (make-cycle (list 1 2 3) :for (make-cycle (list 3 2 1))))
; (next aaa #t)
; (define aaa (make-cycle (list 1 2 3) :limit 2))
; (next aaa #t)
; (define aaa (make-cycle (list (make-cycle (list 'a 'b) ) (make-cycle (list 1 2) ))))
; (next aaa #t)
; (define aaa (make-cycle (list 1 (make-cycle (list 'a 'b)))))
; (next aaa #t)
; (define aaa (make-cycle (list 1 (make-cycle (list 'a 'b) :for (make-cycle (list 3 2 1 0))))))
; (next aaa #t)

;;;
;;; palindrome
;;;

(define-record-type palin
  (make-palin pos len inc mode elide)
  palin?
  (pos palin-pos palin-pos-set!)
  (len palin-len palin-len-set!)
  (inc palin-inc palin-inc-set!)
  (mode palin-mode palin-mode-set!)
  (elide palin-elide palin-elide-set!))


(define (ppalin obj port)
  (list 'palin 
	(palin-pos obj) (palin-len obj) (palin-inc obj)
	(palin-mode obj) (palin-elide obj)))

(define (make-palindrome data . args)
  (unless (pair? data) (set! data (list data)))
  (with-optkeys (args for limit elide)
    (let ((obj (%alloc-pattern))
	  (flags 0)
	  (len (length data)))
      (initialize-pattern obj data for limit
			  flags len (* len 2) next-in-palindrome
			  (lambda (fn obj)
			    (for-each fn (pattern-data obj))))
      ;; pattern cache holds palin structure
      (pattern-cache-set! obj (make-palin -2 (length data) #f #f
					  elide))
      obj)))

(define (next-in-palindrome obj)
  (let* ((cache (pattern-cache obj))
	 (pos (palin-pos cache)))
    (cond ((< pos 0 ) 
	   ;; starting new up-and-back cycle
	   (let ((m (next-1 (palin-elide cache)))
		 (l (palin-len cache))
		 (i (= pos -2)))
	     (palin-mode-set! cache m)
	     (palin-inc-set! cache 1)
	     ;; see if we skip repeat of first element
	     (if (or (eqv? m #t) (and (pair? m) (eqv? (car m) #t)))
		 ;; -2 marks very first call, dont skip inital element
		 (if i (set! pos 0) (set! pos 1))
		 (set! pos 0))	     
	     (if (logtest (pattern-flags obj) +default-period+)
		 (let* ((p (pattern-period obj))
			(c (* l 2)))
		   (cond ((eqv? m #f)
			  (period-count-set! p c))
			 ((eqv? m #t)
			  (period-count-set! p (if i (- c 2) (- c 3))))
			 ((equal? m '(#f #t))
			  (period-count-set! p (- c 1)))
			 ((equal? m '(#t #f))
			  (period-count-set! p (if i (- c 1) (- c 2))))
			 (else (period-count-set! p c)))
		   ))
	     ))
	  ((= pos (palin-len cache))
	   ;; reversing direction
	   (palin-inc-set! cache -1)
	   (let ((m (palin-mode cache)))
	     ;; test if we skip repeat of last element
	     (if (or (eqv? m #t) (and (pair? m) (pair? (cdr m))
				      (eqv? (cadr m) #t)))
		 (set! pos (- pos 2))
		 (set! pos (- pos 1))))
	   ))
    (palin-pos-set! cache (+ pos (palin-inc cache)))
    (list-ref (pattern-data obj) pos)))

; (define aaa (make-palindrome '(a b c d) ))
; (next aaa #t)
; (define aaa (make-palindrome '(a b c d) :elide #t))
; (next aaa #t)
; (define aaa (make-palindrome '(a b c d) :elide '(#f #t)))
; (next aaa #t)
; (define aaa (make-palindrome '(a b c d) :elide '(#t #f)))
; (next aaa #t)
; (define aaa (make-palindrome '(a b c d) :for 3))
; (next aaa #t)

;;;
;;; line sticks on the last element.
;;;

(define (make-line data . args)
  (unless (pair? data) (set! data (list data)))
  (with-optkeys (args for limit)
    (let ((obj (%alloc-pattern))
	  (flags 0)
	  (len (length data)))
      (initialize-pattern obj data for limit flags
			  len len next-in-line
			  (lambda (fn obj)
			    (for-each fn (pattern-data obj))))
      obj)))

(define (next-in-line obj)
  (let ((line (pattern-data obj)))
    (if (null? (cdr line))
	(begin 
	  (period-count-set! (pattern-period obj) 1)
	  (car line)
	  )
	(let ((x (car line)))
	  (pattern-data-set! obj (cdr line))
	  x))))

;;; (define aaa (make-line '(a b c)))
;;; (next aaa #t)
;;; (define aaa (make-line (list 'a 'b (make-cycle '(1 2 3 4)))))
;;; (next aaa #t)
;;; (define aaa (make-line (list 'a 'b (make-cycle '(1 2 3 4) :for (lambda () (+ 1 (random 4)))))))
;;; (next aaa #t)
;;; aaa

;;;
;;; heap shuffles its elements each time through
;;;

(define (make-heap data . args)
  ;; copy data because heap destructively modifies it
  (if (pair? data)
      (set! data (append data (list)))
      (set! data (list data)))
  (with-optkeys (args for limit)
    (let ((obj (%alloc-pattern))
	  (flags 0)
	  (len (length data)))
      (initialize-pattern obj (list data) for limit
			  flags len len next-in-heap
			  (lambda (fn obj)
			    (for-each fn (car (pattern-data obj)))))
      obj)))
  
(define (next-in-heap obj)
  (let ((data (pattern-data obj)))
    (when (null? (cdr data))
      (let ((len (pattern-length obj))
	    (lis (car data)))
	(do ((i 0 (+ i 1))
	     (j (random len) (random len))
	     ;; (j (ffi_ranint len ) (ffi_ranint len))
	     (v #f))
	    ((= i len)
	     (set-cdr! data lis))
	  (set! v (list-ref lis i))
	  (list-set! lis i (list-ref lis j))
	  (list-set! lis j v))))
    (let ((x (cadr data)))
      (set-cdr! data (cddr data))
      x)))

;; (define xxx '(1 2 3 4))
;; (define aaa (make-heap xxx))
;; (next aaa #t)
;; xxx
;; (define aaa (make-heap (list 1 2 3 (make-cycle '(a b c)) 4 5)))
;; (next aaa #t)

;;;
;;; rotation
;;;

(define (make-rotation data . args)
  ;; copy user's data (rotation side effects data)
  (if (pair? data)
      (set! data (append data (list)))
      (set! data (list data)))
  (with-optkeys (args for limit (rotate 0))
    (let ((obj (%alloc-pattern))
	  (flags 0)
	  (len (length data)))
      ;; cdr of data initialized now so that rotations only happen
      ;; after the first cycle.
      ;; (initialize-pattern obj data args flags len dper getr mapr allow)
      (initialize-pattern obj (cons data data) for limit
			  flags len len next-in-rotation
			  (lambda (fn obj) 
			    (for-each fn (car (pattern-data obj)))))
      ;; pattern cache holds palin structure
      (pattern-cache-set! obj rotate)
      obj)))
  
(define (next-in-rotation obj)
  (define (rotate-items items start step width end)
    (do ((i start (+ i step)))
	((not (< i end)) items)
      (let ((a (list-ref items i))
	    (b (list-ref items (+ i width))))
	(list-set! items i b)
	(list-set! items (+ i width) a))))
  (let ((data (pattern-data obj)))
    (when (null? (cdr data))
      (let ((l (car data))
	    (r (next-1 (pattern-cache obj))))
	;; start step width end
	(set-cdr! data
		  (if (pair? r)
		      (if (pair? (cdr r))
			  (if (pair? (cddr r))
			      (if (pair? (cdddr r))
				  (apply rotate-items l r)
				  (rotate-items l (car r) 
						(cadr r) (caddr r)
						;; len - width
						(- (pattern-length obj) 
						   (caddr r))))
			      (rotate-items l (car r) (cadr r) 1
					    (- (pattern-length obj) 1)))
			  (rotate-items l (car r) 1 1 
					(- (pattern-length obj) 1)))
		      (rotate-items l r 1 1 
				    (- (pattern-length obj) 1))))))
    (let ((x (car (cdr data))))
      (set-cdr! data (cddr data))
      x)))

; (define aaa (make-rotation '(a b c d)))
; (next aaa #t)
; (define aaa (make-rotation '(a b c d) :rotations '(1 2)))
; (next aaa #t)

;;;
;;; weighting chooses items using weighted selection. its data are
;;; kept in a list of the form#: ((&rest choices) . last-choice).
;;;

;; (define-record random-item datum index weight min max count id minmax)
(define-record-type random-item
  (make-random-item datum index weight min max count id minmax)
  random-item?
  (datum random-item-datum random-item-datum-set!)
  (index random-item-index random-item-index-set!)
  (weight random-item-weight random-item-weight-set!)
  (min random-item-min random-item-min-set!)
  (max random-item-max random-item-max-set!)
  (count random-item-count random-item-count-set!)
  (id random-item-id random-item-id-set!)
  (minmax random-item-minmax random-item-minmax-set!))

(define (prandom-item obj )
  (list 'random-item
	#:datum (random-item-datum obj)
	#:index (random-item-index obj)
	#:weight (random-item-weight obj)
	#:min (random-item-min obj)
	#:max (random-item-max obj)
	#:count (random-item-count obj)
	#:id (random-item-id obj)
	#:minmax (random-item-minmax obj)))

(define (make-weighting data . args)
  (let* ((pool (canonicalize-weighting-data data))
	 (obj (%alloc-pattern))
	 (len (length pool))
	 (dper #f)
	 (const-weight #t)
	 (const-datums #t)
	 (num-patterns 0)
	 (flags 0))
    (for-each (lambda (item)
		(let ((min (random-item-min item))
		      (max (random-item-max item))
		      (wei (random-item-weight item))
		      (dat (random-item-datum item)))
		  (when (pattern? dat)
		    (set! const-datums #f)
		    (set! num-patterns (+ num-patterns 1)))
		  ;; check the stream for constant weights. if true,
		  ;; calculate the range now and set a flag so we dont
		  ;; recalulate each period.
		  (unless (number? wei)
		    (set! const-weight #f))))
	      pool)
    ;; set the default period length of an all-subpattern weighting to
    ;; 1 otherwise to the number of elements. since a weighting
    ;; pattern establishes no particular order itself, setting the
    ;; period to 1 allows the number of elements in the current period
    ;; to reflect the sub patterns.
    (set! dper (if (= num-patterns len) 1 len))
    (if const-weight (set! flags (logior flags +constant-weights+)))
    ;; pool is ((&rest choices) . last-choice) no initial last
    ;; choice. a first choice for the stream could be implemented as a
    ;; last with min=1
    (with-optkeys (args for limit)
      (initialize-pattern obj (list pool) for limit
			  flags len dper next-in-weighting
			  (lambda (fn obj)
			    (for-each (lambda (i)
					( fn (random-item-datum i)))
				      (car (pattern-data obj))))))
    ;; if we have constant weights calculate the range now as fixnums
    (if const-weight (recalc-weightings obj #t))
    obj))

(define (canonicalize-weighting-data data)
  (define (%make-random-item w)
    (let ((item #f)
	  (args (list)))
      (cond ((pair? w)
	     (set! item (car w))
	     (set! args (cdr w)))
	    (else (set! item w)))
      (with-optkeys (args (weight 1) (min 1) max)
	(make-random-item item #f weight min max 0 #f #f))))
  (map %make-random-item data))

;;; (canonicalize-weighting-data '(a b c))
;;; (canonicalize-weighting-data '(a (b 33) c))
;;; (canonicalize-weighting-data '(a (b :max 33) c))

(define (recalc-weightings obj fix?)
  (let ((data (car (pattern-data obj)))
	(range 0.0))
    (do ((tail data (cdr tail)))
	((null? tail) #f)
      (set! range (+ range (next-1 (random-item-weight (car tail)))))
      (random-item-index-set! (car tail) range))
    (if fix?
	(do ((tail data (cdr tail))
	     (index 0)
	     (total 0))
	    ((null? tail)
	     (pattern-cache-set! obj total) )
	  (set! index (/ (random-item-index (car tail))
			 range))
	  (random-item-index-set! (car tail) index)
	  (set! total index))
	(pattern-cache-set! obj range))))

(define (next-in-weighting obj)
  ;; pool is ((&rest choices) . last-item)
  (let* ((pool (pattern-data obj))
	 (per (pattern-period obj))
	 (flags (pattern-flags obj))
         (last (cdr pool)))
    (unless (logtest flags +constant-weights+)
      ;; at beginning of new period?
      (when (= (period-count per) (period-length per))
	(recalc-weightings obj #f)))
    ;; if we have a last item with an unfulfilled :min value return it
    (if (and (not (null? last))
	     (begin
	      (random-item-count-set! last
				      (+ 1 (random-item-count last)))
	      (< (random-item-count last)
		 (random-item-min last))))
	(random-item-datum last)
	(let ((range (pattern-cache obj))
	      (choices (car pool))
	      (pick (lambda (c r)
		      (do ((tail c (cdr tail))
			   (index (random r))
			   ;; (index (ffi_ranfloat r ))
			   )
			  ( (< index (random-item-index (car tail)))
			    (car tail)))))
	      (next #f))
	  (do ((item (pick choices range) (pick choices range)))
	      ((not (and (random-item-max item)
			 (= (random-item-count item)
			    (random-item-max item))))
	       (set! next item))
	    )
	  (unless (eqv? next last)
	    (do ((tail choices (cdr tail)))
		((null? tail) #f)
	      (random-item-count-set! (car tail) 0)))
	  (set-cdr! pool next)
	  ;; adjust the weight of the newly selected item
	  (random-item-datum next)))))

;;; (define aaa (make-weighting '(a b c d e)))
;;; (next aaa #t)
;;; (define aaa (make-weighting '(a b (c :weight 10) d e)))
;;; (next aaa #t)
;;; (define aaa (make-weighting '(a b (c :min 4) d e)))
;;; (next aaa #t)

;;;
;;; markov 
;;;

(define (canonicalize-markov-data data)
  (define (parse-markov-spec spec)
    (if (not (pair? spec))
	(error "transition ~S is not a list" spec))
    (let ((rhside (or (member '-> spec)
		      (member '#:-> spec)
		      (error "no right hand side in transition ~S"
			     spec)))
	  (lhside (list))
	  (range 0) 
	  (outputs (list)))
      ;; separate lh and rh sides
      (let* ((head (list #f))
	     (tail head))
	(do ()
	    ((eqv? spec rhside)
	     (set! lhside (cdr head))
	     (set! rhside (cdr rhside)))
	  (set-cdr! tail (list (car spec)))
	  (set! tail (cdr tail))
	  (set! spec (cdr spec))))
      (for-each (lambda (s)
		  (let ((val #f)
			(pat #f)
			(wei #f))
		    (if (pair? s)
			(begin (set! val (car s))
			       (set! wei (if (null? (cdr s)) 1 (cadr s)))
			       ;; weight may be number or pattern
			       (set! pat wei)
			       (unless (number? wei)
				 (set! wei #f)))
			(begin (set! val s) (set! wei 1) (set! pat 1)))
		    ;; set range to #f if any weight is pattern
		    ;; else precalc range for the constant weights
		    (if (and wei range)
			(set! range (+ range wei))
			(set! range #f))
		    ;;(push (list val range pat) outputs)
		    (set! outputs (cons (list val range pat) outputs))
		    ))
		rhside)
      (cons lhside (cons range (reverse outputs)))))
    (let ((transitions (list #f)))
      (do ((tail data (cdr tail))
	   (order #f)
	   (lis transitions)
	   (p #f))
	  ((null? tail)
	   (cdr transitions) )
	(set! p (parse-markov-spec (car tail)))
	(if (not order)
	    (set! order (length (car p)))
	    ;;(set! order (max order (length (first p))))
	    (if (not (= order (length (car p))))
		(error "found left hand sides with different number of items in ~S" 
		       data))
	    )
	(set-cdr! lis (list p))
	(set! lis (cdr lis)))))

;;; (parse-markov-spec '(a a -> b  c ))
;;; (canonicalize-markov-data '((a a -> b  c ) ( a b -> a) (c a -> c a)))

(define (make-markov data . args)
  (if (not (pair? data))
      (error "~S is not list of markov transitions" data)
      (set! data (canonicalize-markov-data data)))
  (with-optkeys (args for limit past)
    (let* ((obj (%alloc-pattern))
	   (len (length data))
	   (flags 0))
      (initialize-pattern obj data for limit
			  flags len len next-in-markov
			  (lambda (fn obj)
			    (for-each fn (pattern-data obj))))
      (unless (pair? past)
	(set! past (make-list (length (car (car data))) '*)))
      (pattern-cache-set! obj past)
      obj)))
  
(define (next-in-markov obj)
  ;; markov data kept as a list of lists. each list is in the form#:
  ;; ((<inputs>) range . <output>)
  (letrec ((select-output
            (lambda (range outputs)
              ;; if range is #f then one or more weights in the
              ;; outputs are patterns. in this case we map all the
              ;; outputs to update weights of every outcome and then
              ;; select.  otherwise (range is number) we simply select
              ;; an outcome from the precalculated distribution.
              (if (not range)
		  (do ((tail outputs (cdr tail))
		       (out #f)
		       (sum 0))
		      ((null? tail)
		       (select-output sum outputs))
		    ;; out is outcome#: (val rng <pat/wei>)
		    (set! out (car tail))
		    ;; if third element is number use it else read it
		    (set! sum (+ sum (if (number? (caddr out))
					 (caddr out)
					 (next-1 (caddr out)))))
		    ;; always update second element to new value
		    (set-car! (cdr out) sum))
                (let (
		      (n (random range))
		      ;; (n (ffi_ranfloat range))
		      )
		  (do ((tail outputs (cdr tail)))
		      ((< n (cadr (car tail)))
		       (car (car tail)))))
		)))
	   (match-past
	    (lambda (inputs past)
	      (do ((i inputs (cdr i))
		   (j past (cdr j))
		   (f #t))
		  ((or (null? i) (null? j) (not f))
		   f)
		(set! f (or (eqv? (car i) '*)
			    (equal? (car i) (car j))
			    (eqv? (car j) '*))))
	      )))
    (do ((tail (pattern-data obj) (cdr tail))
	 (past (pattern-cache obj))
	 (item #f)
	 )
	((or (null? tail) (null? past) 
	     (match-past (car (car tail)) past))
	 (when (null? tail)
	   (error "no transition matches past ~S"  past))
	 (set! item (select-output (cadr (car tail))
				   (cddr (car tail))))
	 (unless (null? past)
	   (if (null? (cdr past))
	       (set-car! past item)
	       (do ((last past (cdr last)))
		   ((null? (cdr last))
		    ;; rotate past choices leftward
		    (set-car! past item)
		    (set-cdr! last past)
		    (pattern-cache-set! obj (cdr past))
		    (set-cdr! (cdr last) (list))))))
	 item))
    ))
   
;;; (define aaa (make-markov '((a -> b c d) (b -> a) (c -> d) (d -> (a 3) b c))))
;;; (next aaa 30)

(define (last-pair l)
  (if (pair? (cdr l)) 
      (last-pair (cdr l)) l))

(define (markov-analyze seq . args) 
  (let* ((morder #f) ; markov order
	 (result #f) ; what to return
	 (len (length seq)) 
	 (labels '())			; the set of all outcomes 
	 (table '())
	 (row-label-width 8) 
	 (print-decimals 3)
	 (field (+ print-decimals 2)))	; n.nnn 
    (with-optkeys (args (order 1) (mode 1))
      (set! morder order)
      (set! result mode))
    (unless (member result '(1 2 3))
      (error "~S is not a valid mode value" result))
    (letrec ((add-outcome
	      (lambda (prev next) 
		(let ((entry (find-if (lambda (x)
					  (equal? prev (car x)))
				   table)))
		  (if (not entry) 
		      (set! table (cons (list prev
					      (format #f "~s" prev) 
					      (list next 1))
					table)) 
		      (let ((e (assoc next (cddr entry)))) 
			(if e 
			    (set-car! (cdr e) (+ 1 (cadr e)))
			    (set-cdr! (last-pair (cdr entry))
				      (list (list next 1)))))))))
	     (before?
	      (lambda (x y l) 
		(if (null? x) #t 
                    (let ((p1 (list-index (lambda (z) (equal? (car x) z))
					  l)) 
                          (p2 (list-index (lambda (z) (equal? (car y) z))
					  l)))
                      (cond ((< p1 p2) #t) 
                            ; bug!
                            ;((= p1 p2) (before? (cdr x) (cdr y) l)) 
                            (else #f))))))
	     (liststring 
	      (lambda (l)
		(if (null? l) ""
		    (let ((a (format #f "~a" (car l))))
		      (do ((x (cdr l) (cdr x)))
			  ((null? x) a)
			(set! a
			      (string-append 
			       a (format #f " ~a" (car x))))))))))
      (do ((i 0 (+ i 1)))
	  ((= i len) #f)
	(do ((prev (list))
	     (j 0 (+ j 1))  ; j to morder
	     (x #f))
	    ((> j morder)
	     (add-outcome (reverse prev) x ) 
	     (if (not (member x labels))
		 (set! labels (cons x labels))))
	  (set! x (list-ref seq (modulo (+ i j) len)))
	  ;; gather history in reverse order 
	  (when (< j morder) (set! prev (cons x prev)))))
      ;; sort the outcomes according to data
      (cond ((number? (car labels))
	     (set! labels (sort labels <)))
	    ((and (car labels) (symbol? (car labels)))
	     (set! labels (sort labels
				(lambda (x y) 
				  (string-ci<? (format #f "~a" x)
					       (format #f "~a" y))))))
	    (else 
	     (set! labels (reverse labels))))
      ;; map over data, normalize weights 
      (do ((tail table (cdr tail))
	   (len 0))
	  ((null? tail)
	   (set! row-label-width (max len row-label-width)) )
	(let* ((row (car tail))
	       (lab (cadr row))	; label
	       (val (cddr row)))
	  (set! len (max len (string-length lab)))
	  (let ((total (do ((e val (cdr e)) ; sum all e
			    (s 0))
			   ((null? e) s)
			 (set! s (+ s (cadr (car e))))))) 
	    (set! total (* total 1.0)) 
	    (do ((e val (cdr e)))
		((null? e) #f)
	      (set-car! (cdr (car e))
			(decimals (/ (cadr (car e)) total) 
				  print-decimals))))))
      ;; sort table by labels
      (set! table 
	    (sort table (lambda (x y) (before? (car x) (car y) labels)))) 
      ;; print table
      (when (eqv? result 1)
	(let* ((port (open-output-string))
               (sp " ")
	       (ln (make-string field #\-))) 
	  ;; print column header row
	  (newline port)
	  (do ((i 0 (+ i 1)))
	      ((= i row-label-width) #f)
	    (write-char #\* port))
	  (do ((l labels (cdr l)))
	      ((null? l) #f)
	    (display sp port) ;; column separator
	    (let* ((s (format #f "~a" (car l)))
		   (n (string-length s)))
	      ;; write column pad
	      (do ((i 0 (+ i 1))
		   (m (max (- field n) 0)))
		  ((= i m) #f)
		(write-char #\space port))
	      (display s port)))
	  ;; print each row
	  (do ((tail table (cdr tail)))
	      ((null? tail) #f)
	    (let ((row (car tail)))
	      (newline port)
	      (let* ((s (liststring (car row)))
		     (n (string-length s)))
		;; print left pad for row label
		(do ((i 0 (+ i 1))
		     (m (max (- row-label-width n) 0)))
		    ((= i m) #f)
		  (write-char #\space port))
		;; print row label min row-label-width.
		(do ((i 0 (+ i 1))
		     (m (min row-label-width n)))
		    ((= i m) #f)
		  (write-char (string-ref s i) port)))
	      (do ((l labels (cdr l)))
		  ((null? l) #f)
		(let ((v (assoc (car l) (cddr row))))
		  (if (not v)
		      (begin (display sp port) (display ln port))
		      (let* ((s (number->string (cadr v)))
			     (n (string-length s)))
			(display sp port)
			;; s7: trim number to fit field
			(if (>= n field)
			    (let ((d (char-position #\. s)))
			      (set! s (substring s 0 (min (+ d 4) n)))
			      (set! n (string-length s))))
			;; pad number
			(do ((i 0 (+ i 1))
			     (m (max (- field n) 0)))
			    ((= i m) #f)
			  (write-char #\space port))
			(display s port)
			))))))
	  (newline port)
          (display (get-output-string port))
          (close-output-port port)
          )))

    (if (= result 1)
	(values)
	;; if returning pattern or data convert table to markov lists
	(let ((pat (map (lambda (row)
			  (append (car row) '(->) (cddr row)))
			table)))
	  (if (= result 2)
	      (make-markov pat)
	      pat)))))

; (define aaa '(c4 c4 d4 c4 f4 e4 c4 c4 d4 c4 g4 f4 c4 c4 c5 a4 f4 e4 d4 bf4 bf4 a4 f4 g4 f4))
; (define markovpat (markov-analyze aaa 1 2))
; (next markovpat 30)

;;;
;;; Graph
;;;

;; (define-record graph-node datum to id)
(define-record-type graph-node
  (make-graph-node datum to id)
  graph-node?
  (datum graph-node-datum graph-node-datum-set!)
  (to graph-node-to graph-node-to-set!)
  (id graph-node-id graph-node-id-set!))


(define (pgraph-node obj port)
  (list 'graph-node
	(graph-node-datum obj) (graph-node-to obj)
	(graph-node-id obj)))

(define (make-graph data . args)
  (if (not (pair? data))
      (error "~S is not a list of graph data" data)
      (set! data (canonicalize-graph-data data)))
  (with-optkeys (args for limit)
    (let* ((obj (%alloc-pattern))
	   (len (length data))
	   (flags 0))
      (initialize-pattern obj (cons #f data ) for limit
			  flags len len next-in-graph
			  (lambda (fn obj)
			    (for-each (lambda (n) ( fn (graph-node-datum n)))
				      (cdr (pattern-data obj)))))
      obj)))

(define (canonicalize-graph-data data)
  (let ((pos 1))
    (define (parse-graph-item extern)
      (unless (pair? extern) 
	(error "~S is not a graph node list" extern))
      (apply (lambda (item . args)
	       (with-optkeys (args to id)
		 (unless id (set! id pos))
		 (set! pos (+ pos 1))
		 (make-graph-node item to id)))
	     extern))
    (map parse-graph-item data)))

;; (canonicalize-graph-data '((a :to 2) (b :id 2 :to a)))
;; (canonicalize-graph-data '((a :id 1 :to b) (b :id 2 :to a)))

(define (next-in-graph obj)
  (let* ((graph (pattern-data obj))
         (nodes (cdr graph))
         (this (car graph)))
    (if (not this)
	(begin
	  (set-car! graph (car nodes))
	  (graph-node-datum (car nodes)))
	;; read the to: link and search for next node
	(let ((link (next-1 (graph-node-to this)))
	      (next #f))
	  (do ((tail nodes (cdr tail)))
	      ((or next (null? tail))
	       (if (not next)
		   (error "no graph node for id ~S" link)
		   (set-car! graph next))
	       (graph-node-datum next))
	    (if (eqv? link (graph-node-id (car tail)))
		(set! next (car tail))))))))

;;; (define aaa (make-graph '((a :to b) (b :to a))))
;;; (next aaa)
;;; (define aaa (make-graph `((a :to 2) (b :id 2 :to 3) (c :id 3 :to ,(make-weighting '(1 2 3))))))
;;; (next aaa 20)


;;;
;;; Repeater
;;;

(define (make-repeater pat . args)
  (with-optkeys (args for repeat limit)
		(let ((obj (%alloc-pattern))
		      (flags 0)
		      )
		  (initialize-pattern obj (list) for limit
				      flags
				      0
				      1
				      next-in-repeater
				      (lambda (fn obj)
					(for-each fn (pattern-data obj))))
		  ;; pattern cache holds palin structure
		  (pattern-cache-set! obj (list pat repeat))
		  obj)))

(define (next-in-repeater obj)
  (let ((data (pattern-data obj)))
    (if (null? data)
	(let* ((per (pattern-period obj))
	       (res (next (car (pattern-cache obj)) #t))
	       (len (length res))
	       (for (period-length per))
	       (rep (cadr (pattern-cache obj))))
	  (if rep
	      (begin
		(set! for (next rep))
		(period-length-set! per len)
		(period-count-set! per len))
	      (period-count-set! per (* len for)))
	  (let ((sav res)
		(don (- for 1)))
	    (do ((i 0 (+ i 1)))
		((not (< i don)) #f)
	      (set! res (append res sav))))
	  (pattern-data-set! obj (cdr res))
	  (car res))
	(begin
	  (pattern-data-set! obj (cdr data))
	  (car data)))))


;; (define aaa (make-repeater (make-weighting '(a b c d)) :for 2))
;; (next aaa #t)