(load "ialist.scm")
(load "control.state-module.scm")
(import (ialist)
(control state)
(srfi 116))
;;; Primitives
(define-record-type note
(make-note duration pitch)
note?
(duration note-duration)
(pitch note-pitch))
(define-record-type rest
(make-rest duration)
rest?
(duration rest-duration))
(define (prim? x)
(or (note? x) (rest? x)))
;; Horizontally-appended musics are simply ilists of music values.
(define (sequence? x) (ipair? x))
(define (music-append m1 m2)
(cond ((and (sequence? m1) (sequence? m2)) (iappend m1 m2))
((sequence? m1) (iappend m1 (ilist m2)))
((sequence? m2) (ipair m1 m2))
(else (ilist m1 m2))))
;; Vertically-'zipped' musics, created by music-simul. Unlike
;; sequenced musics, we need to be able to traverse the component
;; music values.
(define-record-type simultaneity
(make-simultaneity part1 part2)
simultaneity?
(part1 simultaneity-part1)
(part2 simultaneity-part2))
;;; Modifiers
(define-record-type modifier
(music-modify context music)
modifier?
(context modifier-context)
(music modifier-music))
;; Lookup key in the context of modifier m.
;; FIXME?: Currently just an ialist.
(define (modifier-ref key m)
(if (modifier? m)
(context-ref key (modifier-context m))
(error "not a modifier" m)))
(define (music? x)
(or (prim? x)
(sequence? x)
(modifier? x)
(simultaneity? x)))
;; An event is a (i)list representation of a Csound score entry.
(define (event-instrument e) (icar e))
(define (event-pfields e) (icdr e))
;; Compute the time value in seconds of a relative duration (fraction
;; of a whole-note) from a base tempo (in quarter-notes per minute).
(define (duration->seconds d tempo)
(/ (* 240 d) tempo))
;; Compute a frequency from a relative pitch and a base frequency.
(define (pitch->frequency p base) (* p base))
;;; A context is a key->value mapping of note properties used to
;;; compile music to events. FIXME: Currently just an ialist.
(define (context? x) (ipair? x))
;; Lookup key in the context ps.
(define (context-ref key ps)
(if (context? ps)
(ialist-ref key ps)
(error "not a context" ps)))
;; If no binding for key exists in context ps, return a new context
;; extended with a binding of key to value.
(define (context-adjoin ps key value)
(if (context? ps)
(ialist-adjoin ps key value)
(error "not a context" ps)))
;; Extend the context ps with a binding of key to value, replacing any
;; previous binding of key in ps.
(define (context-replace ps key value)
(if (context? ps)
(ialist-replace ps key value)
(error "not a context" ps)))
;; Merge two contexts, replacing bindings in cold with those from cnew.
(define (context-merge cold cnew)
(ialist-merge cold cnew))
;; Accessors for important properties
(define (context-instrument ctx) (context-ref 'instrument ctx))
(define (context-tempo ctx) (context-ref 'tempo ctx))
(define (context-base-freq ctx) (context-ref 'base-frequency ctx))
(define (context-pfields ctx) (context-ref 'pfields ctx))
;;; Events
;;;
;;; These are ilists which map directly to Csound score statements.
(define (event? x) (ipair? x))
;; These positions are fixed by Csound syntax.
(define (event-instrument e) (icar e))
(define (event-start-time e) (isecond e))
(define (event-duration e) (ithird e))
;;; Compilation routines
;; cstates are just a bundle of the elapsed seconds and context.
(define-record-type cstate
(make-cstate seconds context)
cstate?
(seconds cstate-seconds)
(context cstate-context))
;; Update c by adding s to the current seconds.
(define (cstate-seconds-inc c s)
(make-cstate (+ s (cstate-seconds c)) (cstate-context c)))
;; Update cs by merging its context with ctx.
(define (cstate-context-merge c ctx)
(make-cstate (cstate-seconds c)
(context-merge (cstate-context c) ctx)))
;; State monad syntax helper.
(define-syntax state-letM*
(syntax-rules ()
((state-letM* () exp) exp)
((state-letM* ((n1 s1) (n2 s2) ...) exp)
(state-bind s1
(lambda (n1)
(state-letM* ((n2 s2) ...)
exp))))))
(define (note->event note ctx start)
(let ((pfs (or (context-pfields ctx) '())))
(iappend (ilist 'i
(context-instrument ctx)
start
(duration->seconds (note-duration note)
(context-tempo ctx))
(pitch->frequency (note-pitch note)
(context-base-freq ctx)))
pfs)))
;; Main compilation entrypoint. All compile- procedures take a
;; music and return a state transformer.
(define (compile-music m)
(cond ((note? m) (compile-note m))
((rest? m) (compile-rest m))
((sequence? m) (compile-sequence m))
((modifier? m) (compile-modifier m))
(else (error "bad argument" m))))
(define (compile-note m)
(state-letM* ((c state-get))
(let ((e (note->event m (cstate-context c) (cstate-seconds c))))
(state-and-then
(state-put (cstate-seconds-inc c (event-duration e)))
(state-pure e)))))
(define (compile-rest m)
(state-modify
(lambda (c)
(cstate-seconds-inc
c
(duration->seconds (rest-duration m)
(context-tempo (cstate-context c)))))))
(define (compile-sequence ms)
(state-traverse compile-music ms))
(define (compile-modifier m)
(state-letM* ((c state-get)
(_ (state-put (cstate-context-merge c
(modifier-context m)))))
(compile-music (modifier-music m))))
;; TODO: compile-simultaneity