procgen  Check-in [ee227e70ef]

(define-macro (rule . body)
  (define (make-cases ct body acc)
    (if (eq? body '()) acc
      (make-cases (+ ct 1) (cdr body)
		(cons (list (list ct) (cons 'string-append (car body))) acc))))
  (list 'define (car body)
	(cons 'case (cons (list 'random-integer (length (cdr body)))
	  (make-cases 0 (cdr body) '()) ))))

(define (pick ar)
  (vector-ref ar (random-integer (vector-length ar))))

(define-macro (one-of . body)
	(define (make-cases ct body acc) ; accumulator func
	; this could probably be done much more cleanly through
	; judicious use of fold or whatever it's called but my
	; brain is too broken
		(if (eq? body '()) ; then
			acc 
		; else
			(make-cases (+ 1 ct) (cdr body) ; recurse!
				(cons `((,ct) ,(car body)) acc)))) ; the rule

	`(case (random-integer ,(length body)) ; final output
		,@(make-cases 0 body '()))
)
(random-source-randomize! default-random-source)

; prep the random number generator
(import (chicken random))
(set-pseudo-random-seed! (random-bytes))

; generates a (case) structure that randomly returns
; one of its branches at equal probability
(define-for-syntax (@one-of case-fn strs)
  ; attach a unique integer value to every item in the
  ; list, descending from (length strs) to 0
  (define (zip lst)
	; inefficient but fun(ctional) way
	(define (long-cons acc new)
	  (cons (cons (length acc) new) acc))
	(foldl long-cons '() lst)) 

  ; return the following list structure
  `(case (pseudo-random-integer ,(length strs))
	 ,@(map case-fn (zip strs))))

; create the case structure for rule expansion
(define-for-syntax (@rewrite-patterns patterns)
  (define (nest-case pair)
	(cons (list (car pair))
		  (cdr pair)))

  (define (wrap pat) 
	(if (eq? (cdr pat) '()) ;then
		pat
		; else
		(list (cons 'string-append pat))))

  (let ([branches (map wrap patterns)])
	(@one-of nest-case branches)))


; exports

	; randomly select and return one of its arguments at runtime
	(define-macro (one-of . strs)
				  (define (flat-case pair)
					(list (list (car pair))
						  (cdr pair)))
				  (@one-of flat-case strs))

	; generates a function that picks and applies one of the
	; patterns passed to it. inner patterns can be expanded
	; with the inner macro (@)
	(define-macro (rule . body)
				  (let ([decl (car body)]
						[patterns (cdr body)])
					`(define ,decl
					   (define-macro (@ . tree) (@rewrite-patterns tree))
					   ,(@rewrite-patterns patterns))))

	(define (pick ar)
		(vector-ref ar (pseudo-random-integer (vector-length ar))))

; [ʞ] lisp-macro
; enable use of the define-macro syntax
; - example -
; 		(define-macro (if-or-f . body)
;			`(if ,(car body) ,(cadr body) #f))

(define-syntax define-macro
	(er-macro-transformer (lambda (exp r c)
		`(define-syntax ,(caadr exp)
			(er-macro-transformer
				(lambda (,(cdadr exp) id-rename id-compare)
					(let ((,(cdadr exp) (cdr ,(cdadr exp))))
			 			,@(cddr exp))))))))