#+TITLE: Ad Libitum
#+SETUPFILE: org-html-themes/org/theme-readtheorg.setup

  The Scheme Live Coding Environment. Built on Chez Scheme and libsoundio.

  You might want to read this file here [[http://ul.mantike.pro/ad-libitum/README.html]]

* Getting Started

  This guide describes initial setup required to produce your first piece of
  digital noise with Ad Libitum. At the moment Ad Libitum is tested only on
  MacOS therefore following instructions are MacOS-specific. Any feedback and
  improvement for other platforms is more than welcome! Current state of Ad
  Libitum dependencies is that it should be easy to port it to Linux and
  moderately hard (but possible) to Windows.

** Chez Scheme

First, you need Chez Scheme itself. Ad Libitum requires threaded version and
you probably don't want to install x11 dependency, that's why better to do it
from source, not brew. Also we are using Racket's fork to be able to build on M1
while https://github.com/cisco/ChezScheme/issues/544 is in progress.

*** Clone Chez Scheme repository

#+BEGIN_SRC shell
git clone https://github.com/racket/ChezScheme.git
cd ChezScheme
#+END_SRC

*** Configure, build and install Chez Scheme

#+BEGIN_SRC shell
./configure --disable-x11
make
sudo make install
#+END_SRC

The first command may suggest you to build boot image first, e.g. on M1:
#+begin_src shell
./configure --pb
make tarm64osx.bootquick
#+end_src

*** Test it's working

    Run =scheme= from terminal and try to evaluate simple expression:

#+BEGIN_SRC shell
~/ChezScheme> scheme

Chez Scheme Version 9.5.5.5
Copyright 1984-2020 Cisco Systems, Inc.

> (+ 1 2 3)
6
>
#+END_SRC

** libsoundio

   This is library used by Ad Libitum for communication with your computer's
   sound system.

#+BEGIN_SRC shell
brew install libsoundio
#+END_SRC

** PortMidi

   You need it if you plan to use MIDI controller.

#+BEGIN_SRC shell
brew install portmidi
#+END_SRC

** Ad Libitum itself

*** Install

   You need to clone repository and build several helping libraries. You may
   need to set ~SCHEMEH~ environment variable to your platform-specific
   location (default value is ~/usr/local/lib/csv9.5.5.5/tarm64osx/~).

#+BEGIN_SRC shell
git clone https://github.com/ul/ad-libitum.git
cd ad-libitum
git submodule update --init --recursive --remote
make libs
#+END_SRC

*** Test

    Fire up =scheme ad-libitum.ss= and play 440Hz tuner (beware of loud sound!
    reduce speakers/headphones volume before running). Congratulations, you
    livecoded your first Ad Libitum piece!

#+BEGIN_SRC scheme
~/ad-libitum> scheme ad-libitum.ss

Chez Scheme Version 9.5.1
Copyright 1984-2017 Cisco Systems, Inc.

> (play! tuner)
>
#+END_SRC

*** Play

    Run & =geiser-connect=

#+BEGIN_SRC shell
scheme --optimize-level 2 violet.ss
#+END_SRC
* Contribution

Contribution is more than welcome and highly appreciated! Any small or non-code
fix is valuable as well, including spelling and grammar and setting proper
licensing.

* Kernel

** Sound I/O

   Ad Libitum relies on =chez-soundio= bindings and high-level wrapper. We are
   going to create and open default i/o (only 'o' at the moment) stream and
   provide it globally.

   For performance reasons =chez-sound= itself doesn't provide any protection
   against broken =write-callback=. But in livecoding mistakes are the part of
   exploration and arguably we want to sacrifice some performance to be able to
   not restart entire sound subsystem for fixing our =write-callback=. That's
   why calling =*dsp*= is wrapped into =guard=.

   To keep our scheduler clock in sync with audio we store audio time and return
   it from =now= function which is passed to scheduler later.

#+NAME: sound
#+BEGIN_SRC scheme
  ;; <sound>
  (define *time* 0.0)
  (define (now) *time*)

  (define (silence time channel) 0.0)
  (define *dsp* silence)
  (define (set-dsp! f) (set! *dsp* f))
  (define (hush!) (set-dsp! silence))

  (define (write-callback time channel)
    (set! *time* time)
    (guard (_ [else 0.0])
      (*dsp* time channel)))

  (define *sound-out* (soundio:open-default-out-stream write-callback))
  (define *sample-rate* (soundio:sample-rate *sound-out*))
  (define *channels* (soundio:channel-count *sound-out*))

  (define (start) (soundio:start-out-stream *sound-out*))
  (define (stop) (soundio:stop-out-stream *sound-out*))
  ;; </sound>
#+END_SRC

** Scheduler

  Much of music is about time. Before we produce any single sample of wave, we
  want to control when to start and when to stop doing it. Much of live coding
  is about decoupling our commands from their execution. We want to say "play
  note a second later" now, but play it a second later. It's where scheduler
  comes to play. Essentially, scheduler's API is simple and allows to get
  current time mark (whatever it means: system clock, time elapsed from
  scheduler start or number of rendered samples) and to callback procedure at
  some point of time with more or less guaranteed skew limit.

  Let's start with scheduler interface. As has been said there are two basic
  functions it must provide, =now= and =schedule=. First one allows to get
  current point in time, and it is usually comes to schedule from external
  source like audio stream to be in sync with it. Second one allows to schedule
  execution at some point in future.

#+NAME: scheduler-interface
#+BEGIN_SRC scheme
  ;; <scheduler-interface>
  <<now>>
  <<schedule>>
  ;; </scheduler-interface>
#+END_SRC

  As far as scheduler is stateful and even involves thread creation, it must
  have two other basic methods:

#+NAME: scheduler-interface
#+BEGIN_SRC scheme
  ;; <scheduler-interface>
  <<start-scheduler>>
  <<stop-scheduler>>
  ;; </scheduler-interface>
#+END_SRC

  Let's shape scheduler's data. Obviously, =now= appears here, in form of either
  scheduler's own counter or function (which will get system time or related
  write thread sample number). Another thing is =queue=, where =schedule= will
  store callbacks. Because queuing could happen from different threads at the
  same time, as well as dequeuing inside scheduler could happen together with
  queuing from another thread, we need to protect it with =mutex=. We also need
  =thread= id or flag or whatever used to control thread exit, because Scheme
  doesn't expose =pthread_kill=. And the last one which comes to the mind at the
  moment is =resolution= as a number of times per second scheduler checks the
  =queue= for expired events.

  Together with record definition we provide =simple-scheduler= which creates
  schedule with reasonable default parameters. The only thing it accepts is
  =now=, because usually you want you schedule to be in sync with external
  clock.

#+NAME: scheduler-record
#+BEGIN_SRC scheme
  ;; <scheduler-record>
  (define-record-type scheduler
    (fields now (mutable queue) resolution (mutable thread) mutex))

  (define (simple-scheduler now)
    (make-scheduler
     now           ; now
     heap/empty    ; queue
     250           ; resolution
     #f            ; thread
     (make-mutex)  ; mutex
     ))
  ;; </scheduler-record>
#+END_SRC

  Let's implement scheduler interface.

  =now= then would just call =now= field:

#+NAME: now
#+BEGIN_SRC scheme
  ;; <now>
  (define (now scheduler) ((scheduler-now scheduler)))
  ;; </now>
#+END_SRC

  Event queue accepts events which must have =f= with its
  =args= to execute at =time=:

#+NAME: event-record
#+BEGIN_SRC scheme
  ;; <event-record>
  (define-record-type event
    (fields time f args))
  ;; </event-record>
#+END_SRC

  For =queue= we need some heap implementation, I'm going to jump into [[Pairing
  Heap]]!

  Mutex is used to prevent data race on insert and remove from queue happening
  in different threads.

  =schedule= should accept either =event= record, or its fields (and create
  record by itself) to unclutter user code.

#+NAME: schedule
#+BEGIN_SRC scheme
  ;; <schedule>
  (define schedule
    (case-lambda
      [(scheduler event)
       (with-mutex (scheduler-mutex scheduler)
                   (scheduler-queue-set! scheduler (heap/insert event-time event (scheduler-queue scheduler))))]
      [(scheduler t f . args)
       (schedule scheduler (make-event (inexact t) f args))]))
  ;; </schedule>
#+END_SRC

  Processing events is just executing any expired events' functions and removing
  them from the queue.

  To enable dynamic temporal recursion we support event's =f= to be a symbol
  referring top level function.

  Of course, live events are error prone, but we don't want flawed event to blow
  entire thread. Thus =f= execution is secured with =guard=.

#+NAME: scheduler-process-events
#+BEGIN_SRC scheme
  ;; <scheduler-process-events>
  (define (process-events scheduler time)
    (with-mutex
     (scheduler-mutex scheduler)
     (let next-event ()
       (let ([event (heap/find-min (scheduler-queue scheduler))])
         (when (and event (<= (event-time event) time))
           (scheduler-queue-set!
            scheduler
            (heap/delete-min event-time (scheduler-queue scheduler)))
           (guard (_ [else #f])
             (let ([f (event-f event)])
               (apply (if (symbol? f)
                          (top-level-value f)
                          f)
                      (event-args event))))
           (next-event))))))
  ;; </scheduler-process-events>
#+END_SRC

  Now it's a time for start/stop thread. Stopping thread would be just setting a
  flag which I used to call "poison pill".

#+NAME: stop-scheduler
#+BEGIN_SRC scheme
  ;; <stop-scheduler>
  (define (stop-scheduler scheduler)
    (scheduler-thread-set! scheduler #f))
  ;; </stop-scheduler>
#+END_SRC

  Starting thread will fork and loop calling expired events. We set expire
  period for a half of resolution period in future to compensate a little bit
  that events could expire during =process-events=. Proper adjustment require
  further investigation taking in account that audio clock is not uniform (it
  moves fast inside filling audio buffer process then waits to buffer to be
  available again).

#+NAME: start-scheduler
#+BEGIN_SRC scheme
  ;; <start-scheduler>
  (define (start-scheduler scheduler)
    (fork-thread
     (lambda ()
       (scheduler-thread-set! scheduler (get-thread-id))
       (let* ([resolution (scheduler-resolution scheduler)]
              [expired-horizon (/ 0.5 resolution)]
              [microseconds-to-sleep (exact (floor (/ 1e6 resolution)))])
         (let loop ()
           (when (scheduler-thread scheduler)
             (process-events scheduler (+ (now scheduler) expired-horizon))
             (usleep 0 microseconds-to-sleep)
             (loop)))))))
  ;; </start-scheduler>
#+END_SRC

#+NAME: scheduler
#+BEGIN_SRC scheme
  ;; <scheduler>
  <<scheduler-record>>
  <<event-record>>
  <<scheduler-process-events>>
  <<scheduler-interface>>
  ;; </scheduler>
#+END_SRC

  We need just a simple default scheduler at hand for Ad Libitum needs:

#+NAME: easy-scheduler
#+BEGIN_SRC scheme
  (define *scheduler* #f)
  (define (init now) (set! *scheduler* (simple-scheduler now)))
  (define (start) (start-scheduler *scheduler*))
  (define (stop) (stop-scheduler *scheduler*))
  (define (*schedule* t f . args) (schedule *scheduler* (make-event t f args)))
  (define (*now*) (now *scheduler*))
#+END_SRC

*** Pairing Heap

   Wikipedia's type definition for pairing heap structure looks like Scheme's
   pairs (surprise =) ). Using them implementation is quite straightforward.

#+NAME: pairing-heap
#+BEGIN_SRC scheme
  ;; <pairing-heap>
  ;; we do some #f-punning and don't throw on empty heaps

  (define heap/empty '())

  (define (heap/find-min heap)
    (if (null? heap)
        #f
        (car heap)))

  (define (heap/merge comparator h1 h2)
    (cond
     [(null? h1) h2]
     [(null? h2) h1]
     [(< (comparator (car h1)) (comparator (car h2)))
      (cons (car h1) (cons h2 (cdr h1)))]
     [else
      (cons (car h2) (cons h1 (cdr h2)))]))

  (define (heap/insert comparator elem heap)
    (heap/merge comparator (cons elem '()) heap))

  (define (heap/merge-pairs comparator subheaps)
    (cond
     [(null? subheaps) heap/empty]
     [(null? (cdr subheaps)) (car subheaps)]
     [else (heap/merge comparator
            (heap/merge comparator (car subheaps) (cadr subheaps))
            (heap/merge-pairs comparator (cddr subheaps)))]))

  (define (heap/delete-min comparator heap)
    (if (null? heap)
        heap/empty
        (heap/merge-pairs comparator (cdr heap))))
  ;; </pairing-heap>
#+END_SRC

** Remote REPL

NB. REPL is currently disabled as sockets library doesn't work on M1.
To enable it back uncomment ~(repl:start-repl-server)~ in ~ad-libitum-init~.

   We need own repl server because music doesn't work in geiser repl for
   somewhat reason. The most universal solution would be to have REPL over
   either UDP or TCP with the simplest possible protocol. We want it to be just
   a carrier, everything else should happen inside editor and engine. Sadly Chez
   Scheme has no sockets in its std lib. We are gonna try Aaron W. Hsu's
   [[https://github.com/arcfide/chez-sockets][chez-sockets]] library.

   Actually, we are still able to use Geiser with our REPL server because it
   supports remote REPL. See "Connecting to an external Scheme" at [[http://www.nongnu.org/geiser/geiser_3.html#The-REPL][docs]]. The
   only thing required for it is to load =scheme/chez/geiser/geiser.ss= into the
   REPL thread.

   First, let's create a TCP socket. Here we rely on assumption, that default
   protocol is TCP.

*** TODO Ensure that protocol is TCP

*** Blocking vs Async sockets

    Though Aaron doesn't recommend using blocking sockets, they are so much
    easier for our case! No need to implement polling when waiting for
    connection or receiving value.

    Tried blocking sockets. They work fine by themselves, but play bad with
    =sleep= called from other threads! Falling back to async sockets and polling
    then.

*** Open socket

#+NAME: open-socket
#+BEGIN_SRC scheme
  ;; <open-socket>
  (define (open-socket)
    (let ([socket (sock:create-socket
                   sock:socket-domain/internet
                   sock:socket-type/stream
                   sock:socket-protocol/auto)])
      <<bind-socket>>
      <<listen-socket>>
      socket
      ))
  ;; </open-socket>
#+END_SRC

    Then we are going to listen address and port for input. We'll make it
    configurable later, let's provide some sensible hardcoded defaults for now.
    /localhost/ is for security reasons, and /37146/ is default Geiser port.

#+NAME: bind-socket
#+BEGIN_SRC scheme
  ;; <bind-socket>
  (sock:bind-socket socket (sock:string->internet-address "127.0.0.1:37146"))
  ;; </bind-socket>
#+END_SRC

    And then let's listen for new connections!

#+NAME: listen-socket
#+BEGIN_SRC scheme
  ;; <listen-socket>
  (sock:listen-socket socket 1024)
  ;; </listen-socket>
#+END_SRC

*** Accept connections

    To actually accept new connections we are going to create new thread and
    just run infinite loop with =accept-socket= inside. Remember, our socket is
    non-blocking so we are to make polling to not eat all CPU by eager calls.
    After accepting new connection we'll proceed it in new thread.

#+NAME: accept-connections
#+BEGIN_SRC scheme
  ;; <accept-connections>
  (define (accept-connections repl-server-socket)
    (fork-thread
     (lambda ()
       (let loop ()
         (usleep 0 polling-microseconds)
         (let-values ([(socket address) (sock:accept-socket repl-server-socket)])
           (when socket
             (printf "New REPL @ ~s\r\n" (sock:internet-address->string address))
             (spawn-remote-repl socket address)))
         (loop)))))
  ;; </accept-connections>
#+END_SRC

*** Spawn remote REPL

    Every new connection accepted would spawn new thread with a REPL loop inside
    it. Because we are using async sockets, we are forced to run actual loop and
    poll socket for values. /50ms/ should be a reasonable polling delay to keep
    it responsive and not resource greedy at the same time. Also
    =receive-from-socket= require to limit maximum message length. Here /65k/ is
    also is a kind of a guess. Chez Scheme operates UTF-8 strings and messages
    are read as bytevectors from sockets, thus we need a transcoder to convert
    them back and forth. Let's put all these requirements to values:

#+NAME: spawn-remote-repl-options
#+BEGIN_SRC scheme
  ;; <spawn-remote-repl-options>
  (define polling-microseconds 50000)
  (define max-chunk-length 65536)
  (define code-tx (make-transcoder (utf-8-codec) (eol-style lf) (error-handling-mode replace)))
  ;; </spawn-remote-repl-options>
#+END_SRC

    Preparations are straightforward: define some helpers, send initial prompt,
    and start loop.

#+NAME: spawn-remote-repl
#+BEGIN_SRC scheme
  ;; <spawn-remote-repl>
  <<spawn-remote-repl-options>>
  (define (spawn-remote-repl socket address)
    (fork-thread
     (lambda ()
       (let* (
              <<repl-send-helpers>>
              )
         (send-prompt)
         <<repl-loop>>
         ))))
  ;; </spawn-remote-repl>
#+END_SRC

    Converting messages to bytevectors and sending to proper port is quite
    tedious, let's write a couple of helpers:

#+NAME: repl-send-helpers
#+BEGIN_SRC scheme
  ;; <repl-send-helpers>
  [call-with-send-port
   (lambda (f)
     (let ([response (call-with-bytevector-output-port f code-tx)])
       (sock:send-to-socket socket response address)))]
  [send-prompt
   (lambda ()
     (call-with-send-port (lambda (p) (display "> " p))))]
  ;; </repl-send-helpers>
#+END_SRC

    Loop starts with polling delay. For simplicity it's constant and
    unconditional in the beginning of every cycle. If socket is ready and
    contains non-empty message then we do evaluation and send result back.
    Reading from socket is implemented via ports, look at =chez-socket=
    documentation for more info.

#+NAME: repl-loop
#+BEGIN_SRC scheme
  ;; <repl-loop>
  (let loop ()
    (usleep 0 polling-microseconds)
    (let-values ([(request address)
                  (sock:receive-from-socket socket max-chunk-length)])
      (if (and request (positive? (bytevector-length request)))
          (call-with-port
           (open-bytevector-input-port request code-tx)
           <<repl-read-eval-print>>
           )
          (loop))))
  ;; </repl-loop>
#+END_SRC

    Our remote REPL supports multi-form messages, therefore we need inner loop to
    read and process them one by one.

#+NAME: repl-read-eval-print
#+BEGIN_SRC scheme
  ;; <repl-read-eval-print>
  (lambda (p)
    (do ([x (read p) (read p)])
        ((eof-object? x))
      (printf "> ~s\r\n" x)
      (call-with-send-port
       <<repl-eval-print>>
       ))
    (send-prompt)
    (loop))
  ;; </repl-read-eval-print>
#+END_SRC

    Eval and send result back, easy, huh?

#+NAME: repl-eval-print
#+BEGIN_SRC scheme
  ;; <repl-eval-print>
  (lambda (p)
    (let* (
           <<repl-eval>>
           )
      <<repl-print>>
      )
    )
  ;; </repl-eval-print>
#+END_SRC

    Tricky part is that we want to:

      - capture output performed by evaluated form
      - capture result of form evaluated
      - don't blow up on exception and capture its message

    That's why we can't just call =eval=

#+NAME: repl-eval
#+BEGIN_SRC scheme
  ;; <repl-eval>
  [result #f]
  [output
   (with-output-to-string
     (lambda ()
       (set! result (guard (x [else (display-condition x)]) (eval x)))))]
  ;; </repl-eval>
#+END_SRC

    On the other hand, sending is quite straightforward, because we need just to
    write to port provided by =call-with-send-port=

#+NAME: repl-print
#+BEGIN_SRC scheme
  ;; <repl-print>
  (printf "| ~s\r\n" output)
  (printf "< ~s\r\n" result)
  (display output p)
  (display result p)
  (newline p)
  ;; </repl-print>
#+END_SRC

*** TODO Stop loop and close socket on disconnect

*** Start REPL server

#+NAME: start-repl-server
#+BEGIN_SRC scheme
  ;; <start-repl-server>
  (define (start-repl-server)
    (accept-connections (open-socket)))
  ;; </start-repl-server>
#+END_SRC

* Core

  Woohoo! Naive [[Kernel]] draft is here and we could start to explore Core basics
  of Sound. At this point Ad Libitum splits into into interwinded parts: the
  framework and the book. In the framework we are going to grow all necessary
  instruments for live coding. In the book we are going to use those instruments
  to experiment with sound.

  One of the naming principles of Ad Libitum variables and functions is that
  they should have proper long self-describing name for clarity and could have
  any funky alias for shortening during performance and for fun cryptic
  librettos.

** Math

   Before diving into the abyss of digital music let's define several useful
   basic math constants and functions.

#+NAME: basic-math
#+BEGIN_SRC scheme
  ;; <basic-math>
  (define pi (inexact (* (asin 1.0) 2)))
  (define two-pi (* 2.0 pi))
  (alias π pi)
  (alias 2π two-pi)

  (define (random-amplitude)
    (- (random 2.0) 1.0))

  (define (clamp value start end)
    (cond
     [(< value start) start]
     [(> value end) end]
     [else value]))
  ;; </basic-math>
#+END_SRC

** Generators

   Sound is about motion. About our mean of sensing somewhat periodic motion
   a.k.a waves. The higher is period, the higher is signal pitch. Waveform
   determines character of signal. And irregularities determine... Something.
   Noise? Personality? We'll try to discover.

   Though signal demonstration usually started with sine waveform as the most
   recognizable and surprisingly pleasant one, we are going to start with
   computationally simplest one (though potentially not the fastest to calculate).

   Technically, the simplest generator is just a constant value, no motion,
   silence. But which stands next in simplicity?

   It's the signal, which is in one position half of a time and in another position
   in another half. By "time" here I mean one cycle, one period of signal.

   But first let define a couple of constants to start with. It's a frequency we
   want to hear and its derivatives.

#+NAME: tuner-constants
#+BEGIN_SRC scheme
  ;; <tuner-constants>
  (define tuner-frequency 440.0)
  (define tuner-period (/ tuner-frequency))
  (define tuner-half-period (* 0.5 tuner-period))
  ;; </tuner-constants>
#+END_SRC

#+NAME: simplest-oscillator
#+BEGIN_SRC scheme
  ;; <simplest-oscillator>
  (define (simplest-oscillator time channel)
    (if (> (mod time tuner-period) tuner-half-period)
        1.0
        -1.0))
  ;; </simplest-oscillator>
#+END_SRC

   Actually, this waveform is called square, because of shape. Once we'll add
   visualisation library to Ad Libitum, before that try to draw function plot by hands.

   Feel free to experiment with different waveforms, we will do it together
   later. Let's step back and look at our example and try to come up with useful
   abstraction. Our DSP callback has signature =f(time, channel) -> amplitude=,
   which is the basis for any audio signal. But what prevents us using audio
   signals as the main medium for building sound? Nothing! It's even very handy.
   Audio signals then are capable of control parameters of other signal,
   naturally forming audio graph. And Chez Scheme should optimize that CSP-like
   style well. But we need to think carefully ahead of time about signature
   itself. What if later we want add additional information flowing every
   sample? What if returning just float is not enough to express all we want?
   Because it's very beautiful, that every signal could be either interpreted as
   a DSP callback alone, and could be passed to other signals. But in the latter
   case sometimes it's not enough to communicate between signals with a single
   float. Perhaps something like =f(time, channel, data) -> (amplitude, data)=
   could do the job? Where structure of =data= is determined by your
   application, and parent signal is responsible for using or discarding the
   =data= returned by child signal. OTOH, =data= in parameters plays like a
   container for some global state to survive between samples, and we could
   replace it with actual global or closured state in our application. The same
   thing for returned data.

   Let's start with =f(time, channel) -> amplitude= then and pray that we didn't
   overlook something important.

   To ease writing signal creators and spotting them in code let's introduce
   small helper:

#+NAME: signal
#+BEGIN_SRC scheme
  ;; <signal>
  (define-syntax (signal stx)
    (syntax-case stx ()
      [(k body ...)
       (with-syntax ([time (datum->syntax #'k 'time)]
                     [channel (datum->syntax #'k 'channel)])
         #'(λ (time channel) body ...))]))

  (alias ~< signal)

  (define-syntax (define-signal stx)
    (syntax-case stx ()
      [(k args body ...)
       (with-syntax ([time (datum->syntax #'k 'time)]
                     [channel (datum->syntax #'k 'channel)])
         #'(define args
             (λ (time channel)
               body ...)))]))

  (alias define~ define-signal)
  ;; </signal>
#+END_SRC

   Usage of that syntax sugar is highly encouraged as it eases refactor in case
   of arguments change, e.g. adding sample from audio input.

   The most basic signal is just a constant one, which is essentially created by
   our shiny new syntax =(~< amplitude)=. But =~<= is a macro and having
   function is useful for composition matters:

#+NAME: constant
#+BEGIN_SRC scheme
  ;; <constant>
  (define~ (constant amplitude) amplitude)
  ;; </constant>
#+END_SRC

   Then we are able to define =silence= as follows:

#+NAME: silence
#+BEGIN_SRC scheme
  ;; <silence>
  (define~ silence 0.0)
  (alias ∅ silence)
  ;; </silence>
#+END_SRC

   Quick question for self-test: what sound would =(~< 1.0)= produce?

   Though it's still very useful signal, let give it a separate name:

#+NAME: unit
#+BEGIN_SRC scheme
(define~ unit 1.0)
#+END_SRC

   Another useful syntax sugar is for referrign and setting vector element
   corresponding to the current channel. It is very common pattern to store
   signal state in vector on per-channel basis.

#+NAME: channel
#+BEGIN_SRC scheme
  ;; <channel>
  (define-syntax (make-channel-vector stx)
    (syntax-case stx ()
      [(k)
       (with-syntax ([*channels* (datum->syntax #'k '*channels*)])
         #'(make-vector *channels*))]
      [(k value)
       (with-syntax ([*channels* (datum->syntax #'k '*channels*)])
         #'(make-vector *channels* value))]))

  (define-syntax (channel-ref stx)
    (syntax-case stx ()
      [(k name)
       (with-syntax ([channel (datum->syntax #'k 'channel)])
         #'(vector-ref name channel))]))

  (define-syntax (channel-set! stx)
    (syntax-case stx ()
      [(k name value)
       (with-syntax ([channel (datum->syntax #'k 'channel)])
         #'(vector-set! name channel value))]))
  ;; </channel>
#+END_SRC

   For composing signal creators we could define a helper, which is the regular
   function composition!

#+NAME: compose
#+BEGIN_SRC scheme
  ;; <compose>
  (define (compose . fns)
    (define (make-chain fn chain)
      (λ args (call-with-values (cut apply fn args) chain)))
    (reduce make-chain values fns))

  (alias ∘ compose)
  ;; </compose>
#+END_SRC

   For unifying oscillators we are going to define signal which will care about
   converting time to proper phase. When you deal with periodic signals it's
   important to distinguish time from phase, because at different frequencies
   phase would be different at the given point of time. Which is okay when
   frequency of you oscillator is constant. When it's variable as in FM
   synthesis, you need to track phase for your oscillator to make it behave
   properly. Let's create special signal =phasor= for that purpose. It will take
   =frequency= signal and =phase0= signal and return signal of phase in =[0, 1)=
   half-interval.

   Here we have an opportunity for a small syntactic improvement. The use-case
   when signal is applied to parameters named exactly =time= and =channel= in
   current scope is very common. Let's create a special syntax for it.

#+NAME: deref-signal
#+BEGIN_SRC scheme
  (define-syntax (<~ stx)
    (syntax-case stx ()
      [(k signal)
       (with-syntax ([time (datum->syntax #'k 'time)]
                     [channel (datum->syntax #'k 'channel)])
         #'(signal time channel))]))
#+END_SRC

   There is a need trick to increase performance w/o breaching abstraction. If
   you have composite signal which you are sure produces same samples for every
   channel then you can build composite signal as usual, but wrap it in =mono=
   in the end to reduce load.

#+NAME: mono
#+BEGIN_SRC scheme
  ;; <mono>
  (define (mono signal)
    (let ([x 0.0])
      (~<
       (when (zero? channel)
         (set! x (<~ signal)))
       x)))
  ;; </mono>
#+END_SRC

   Let's use it in our phasor signal. Phasor is used so frequently that we want
   to provide a small optimization for the case when frequency is known to be
   constant.

   Note that =dynamic-phasor= relies on being called sample by sample. Skipping
   samples is okay-ish (it's like pausing phasor), but calling the same phasor
   from several other signals could make it move too fast. We need additional
   check to protect it.

#+NAME: phasor
#+BEGIN_SRC scheme
  ;; <phasor>
  (define (dynamic-phasor frequency phase0)
    (let ([previous-times (make-channel-vector 0.0)]
          [previous-phases (make-channel-vector 0.0)])
      (~<
       (let* ([previous-time (channel-ref previous-times)]
              [phase-delta (if (< previous-time time)
                               (/ (<~ frequency) *sample-rate*)
                               0.0)]
              [next-phase (-> (channel-ref previous-phases)
                              (+ phase-delta)
                              (mod 1.0))])
         (channel-set! previous-times time)
         (channel-set! previous-phases next-phase)
         (-> (<~ phase0)
             (+ next-phase)
             (mod 1.0))))))

  (define~ (static-phasor frequency phase0)
    (-> time (* frequency) (+ phase0) (mod 1.0)))

  (define phasor
    (case-lambda
      [(frequency phase0)
       (if (number? frequency)
           (static-phasor frequency phase0)
           (dynamic-phasor frequency phase0))]
      [(frequency)
       (if (number? frequency)
           (static-phasor frequency 0.0)
           (dynamic-phasor frequency ∅))]))

  (alias /// phasor)
  ;; </phasor>
#+END_SRC

   Then basic waveforms are defined in very clean way:

#+NAME: waveforms
#+BEGIN_SRC scheme
  ;; <waveforms>
  (define~ (sine phase)
    (sin (* 2π (<~ phase))))

  (define~ (cosine phase)
    (cos (* 2π (<~ phase))))

  (define~ (square phase)
    (if (< (<~ phase) 0.5)
        1.0
        -1.0))

  ;; when `pulse-width' is `(constant 0.5)' it's identical to `square-wave'
  (define~ (pulse pulse-width phase)
    (if (< (<~ phase) (<~ pulse-width))
        1.0
        -1.0))

  (define~ (tri phase)
    (let ([phase (<~ phase)])
      (if (< phase 0.5)
          (- (* 4.0 phase) 1.0)
          (+ (* -4.0 phase) 3.0))))

  (define~ (saw phase)
    (- (* 2.0 (<~ phase)) 1.0))

  (define (sampler table phase)
    (let* ([N (vector-length (vector-ref table 0))]
           [N-1 (- N 1)]
           [n (fixnum->flonum N)])
      (~< (let ([position (* n (<~ phase))])
            (let ([i (-> position
                         (fltruncate)
                         (flonum->fixnum)
                         (clamp 0 N-1))]
                  [a (mod position 1.0)]
                  [table (channel-ref table)])
              (+ (* (- 1.0 a) (vector-ref table i))
                 (* a (vector-ref table (mod (+ i 1) N)))))))))

  (define (unroll signal base-frequency)
    (let* ([n (-> *sample-rate* (/ base-frequency) (round) (exact))]
           [table (make-channel-vector)])
      (do-ec (: channel *channels*)
             (channel-set! table (make-vector n)))
      ;; channel is in inner loop because many `signal' functions
      ;; rely on ordered sample-by-sample execution
      (do-ec (: sample n)
             (: channel *channels*)
             (vector-set!
              (channel-ref table)
              sample
              (signal (/ sample *sample-rate*) channel)))
      table))

  (define sine/// (∘ sine phasor))
  (define cosine/// (∘ cosine phasor))
  (define square/// (∘ square phasor))
  (define pulse///
    (case-lambda
      [(pulse-width frequency phase0)
       (pulse pulse-width (phasor frequency phase0))]
      [(pulse-width frequency)
       (pulse pulse-width (phasor frequency ∅))]))
  (define tri/// (∘ tri phasor))
  (define saw/// (∘ saw phasor))
  (define sampler///
    (case-lambda
      [(table frequency) (sampler table (phasor frequency))]
      [(table frequency phase0) (sampler table (phasor frequency phase0))]))
  ;; </waveforms>
#+END_SRC

   Before we play something interesting with stuff we already defined we need
   one more helper. Drawback of our way of composition of signals is that we
   can't change code of one of them in live and make changed reloaded live, even
   if signal is not anonymous and was defined as a top-level variable. For
   signal which we plan to reload dynamically we are going to introduce wrapper
   which will look for given signal's symbol on every invocation:

#+NAME: live-signal
#+BEGIN_SRC scheme
  ;; <live-signal>
  (define~ (live-signal symbol) (<~ (top-level-value symbol)))
  ;; </live-signal>
#+END_SRC

   Also useful to have live value counterpart:

#+NAME: live-value
#+BEGIN_SRC scheme
  ;; <live-value>
  (define~ (live-value symbol) (top-level-value symbol))
  ;; </live-value>
#+END_SRC

   Next step is implementation of signal arithmetics to ease their mixing and
   matching.

#+NAME: signal-operators
#+BEGIN_SRC scheme
  ;; <signal-operators>
  (define~ (signal-sum* x y)
    (+ (<~ x) (<~ y)))

  (define (signal-sum x . xs)
    (fold-left signal-sum* x xs))

  (define~ (signal-prod* x y)
    (* (<~ x) (<~ y)))

  (define (signal-prod x . xs)
    (fold-left signal-prod* x xs))

  (define (signal-diff x . xs)
    (let ([y (apply signal-sum xs)])
      (~< (- (<~ x) (<~ y)))))

  (define (signal-div x . xs)
    (let ([y (apply signal-prod xs)])
      (~< (/ (<~ x) (<~ y)))))

  (alias +~ signal-sum)
  (alias *~ signal-prod)
  (alias -~ signal-diff)
  (alias /~ signal-div)

  (define ∑ (cut apply signal-sum <...>))

  (define ∏ (cut apply signal-prod <...>))

  ;; normalizing +~
  (define (mix . args)
    (*~ (∑ args) (constant (inexact (/ (sqrt (length args)))))))

  (define~ (pan p)
    (let ([p (* 0.5 (+ 1.0 (<~ p)))])
      (if (zero? channel)
          (- 1.0 p)
          p)))

  (define~ (phase->interval phase start end)
    (let ([phase (<~ phase)]
          [start (<~ start)]
          [end (<~ end)])
      (+ start (* phase (- end start)))))

  (define~ (amplitude->phase s)
    (* 0.5 (+ 1.0 (<~ s))))
  ;; </signal-operators>
#+END_SRC

** Envelopes

*** ADSR

   ADSR envelope shapes signal with polyline described with 4 parameters:

   - Attack time is the time taken for initial run-up of level from nil to peak,
     beginning when the key is first pressed.
   - Decay time is the time taken for the subsequent run down from the attack
     level to the designated sustain level.
   - Sustain level is the level during the main sequence of the sound's
     duration, until the key is released.
   - Release time is the time taken for the level to decay from the sustain
     level to zero after the key is released.

   (Thanks, [[https://en.wikipedia.org/wiki/Synthesizer#Attack_Decay_Sustain_Release_.28ADSR.29_envelope][Wikipedia]])

   Two more parameter required to apply envelope in real performance: note's
   moments of start and end. To make envelope generic and open for crazy
   experiments all 6 parameters are going to be signals:

#+NAME: adsr
#+BEGIN_SRC scheme
  ;; <adsr>
  (define~ (adsr start end attack decay sustain release)
    (let ([end (<~ end)])
      (if (<= end time)
          ;; NOTE OFF
          (let ([Δt (- time end)]
                [r (<~ release)])
            (if (and (positive? r)
                     (<= Δt r))
                (* (- 1.0 (/ Δt r)) (<~ sustain))
                0.0))
          ;; NOTE ON
          (let ([start (<~ start)])
            (if (<= start time)
                (let ([Δt (- time start)]
                      [a (<~ attack)])
                  (if (and (positive? a)
                           (<= Δt a))
                      (/ Δt a)
                      (let ([Δt (- Δt a)]
                            [d (<~ decay)]
                            [s (<~ sustain)])
                        (if (and (positive? d)
                                 (<= Δt d))
                            (- 1.0 (* (- 1.0 s) (/ Δt d)))
                            s))))
                0.0)))))
  ;; </adsr>
#+END_SRC

   Let's test it with simple note play:

#+NAME: play-note
#+BEGIN_SRC scheme
  ;; <play-note>
  (define (simple-instrument start end freq a d s r)
    (let* ([start (live-value start)]
           [end (live-value end)]
           [freq (live-value freq)]
           [osc (sine-wave (phasor freq))]
           [env (adsr start end (~< a) (~< d) (~< s) (~< r))])
      (*~ env osc)))

  (define (make-play-note start end frequency)
    (λ (freq dur)
      (set-top-level-value! frequency freq)
      (set-top-level-value! start (now))
      (set-top-level-value! end (+ (now) dur))))

  ;; (define start 0.0)
  ;; (define end 1.0)
  ;; (define frequency 440.0)

  ;; (define inst (simple-intrument 'start 'end 'frequency 0.3 0.5 0.8 1.0))
  ;; (define play-note (make-play-note 'start 'end 'frequency))

  ;; (sound:set-dsp! (live-signal 'inst))
  ;; (play-note 440.0 1.1)
  ;; </play-note>
#+END_SRC

   We return to instrument concept later and come up with better design for it.

*** Impulse

    Another simple though useful envelope is impulse.

#+NAME: impulse
#+BEGIN_SRC scheme
  ;; <impulse>
  (define~ (impulse start apex)
    (let ([start (<~ start)])
      (if (<= start time)
          (let ([h (/ (- time start)
                      (- (<~ apex) start))])
            (* h (exp (- 1.0 h))))
          0.0)))
  ;; </impulse>
#+END_SRC

*** Transition

#+NAME: transition
#+BEGIN_SRC scheme
  ;; <transition>
  (define (transition curve Δt signal)
    (let ([starts (make-channel-vector (now))]
          [previous-values (make-channel-vector 0.0)]
          [current-values (make-channel-vector 0.0)]
          [next-values (make-channel-vector 0.0)])
      (~<
       (let ([Δt (<~ Δt)]
             [current-value (<~ signal)]
             [next-value (channel-ref next-values)])
         (unless (= current-value next-value)
           (channel-set! previous-values (channel-ref current-values))
           (channel-set! next-values current-value)
           (channel-set! starts time))
         (let ([current-value
                (let ([δt (- time (channel-ref starts))])
                  (if (and (positive? Δt) (< δt Δt))
                      (let ([previous-value (channel-ref previous-values)])
                        (+ previous-value
                           (curve (/ δt Δt) (- current-value previous-value))))
                      current-value))])
           (channel-set! current-values current-value)
           current-value)))))

  (define (instant-curve a Δx)
    Δx)

  (define (linear-curve a Δx)
    (* a Δx))

  (define (quadratic-curve a Δx)
    (* (expt a 4.0) Δx))

  (define instant-transition (cut transition instant-curve unit <>))
  (define linear-transition (cut transition linear-curve <> <>))
  (define quadratic-transition (cut transition quadratic-curve <> <>))
  ;; </transition>
#+END_SRC

** Metronome

  Metronome is a mean to align scheduling with some periodic beat.

#+NAME: beat
#+BEGIN_SRC scheme
  ;; <beat>
  (define (time->beat time bpm)
    (-> time (* bpm) (/ 60) (round)))

  (define (beat->time beat bpm)
    (-> beat (* 60) (/ bpm)))

  (define (next-beat time bpm)
    (beat->time (+ 1 (time->beat time bpm)) bpm))

  (define (metro bpm . args)
    (apply schedule (next-beat (now) bpm) args))

  (define *bpm* 60.0)

  (define (set-bpm! bpm)
    (set! *bpm* bpm))

  (define (*beat*)
    (time->beat (now) *bpm*))

  (define (*metro* . args)
    (apply metro *bpm* args))
  ;; </beat>
#+END_SRC

** Control signals

#+NAME: control-signal
#+BEGIN_SRC scheme
  ;; <control-signal>
  (define (make-control x)
    (let ([b (box x)])
      (values (~< (unbox b)) b)))

  (define-syntax (define-control stx)
    (define construct-name
      (lambda (template-identifier . args)
        (datum->syntax
         template-identifier
         (string->symbol
          (apply string-append
                 (map (lambda (x)
                        (if (string? x)
                            x
                            (symbol->string (syntax->datum x))))
                      args))))))
    (syntax-case stx ()
      [(_ name initial-value)
       (with-syntax ([s (construct-name #'name #'name '~)]
                     [ref (construct-name #'name #'name '-ref)]
                     [set (construct-name #'name #'name '-set!)])
         #'(begin
             (define-values (s name) (make-control initial-value))
             (define (ref) (unbox name))
             (define (set value) (set-box! name value))))]))
  ;; </control-signal>
#+END_SRC

    Hand by hand with control signal go various measurements. For them
    signal-proxy =window= is very useful. It's result also could be used as the
    input table for =osc:sampler=.

#+NAME: window
#+BEGIN_SRC scheme
  ;; <window>
  (define (window width signal)
    (let ([windows (make-vector *channels*)]
          [N (-> width (* *sample-rate*) (ceiling) (exact))]
          [cursor -1])
      (do-ec (: i *channels*)
             (vector-set! windows i (make-vector N 0.0)))
      (values
       (~<
        (when (zero? channel)
          (set! cursor (mod (+ cursor 1) N)))
        (let ([sample (<~ signal)]
              [window (channel-ref windows)])
          (vector-set! window cursor sample)
          sample))
       (λ () windows))))
  ;; </window>
#+END_SRC

* Std

** FFT
** Filters

#+NAME: delay
#+BEGIN_SRC scheme
  ;; <delay>
  (define~ (delay Δt f)
    (f (- time (<~ Δt)) channel))
  ;; </delay>
#+END_SRC

#+NAME: echo
#+BEGIN_SRC scheme
  ;; <echo>
  (define *max-line-duration-slow* 10)
  (define *max-line-duration-fast* 1)

  (define (make-echo max-line-duration)
    (λ (delay feedback signal)
      (let ([line-size (* max-line-duration *sample-rate*)]
            [lines (make-channel-vector)]
            [cursor -1])
        (do ([channel 0 (+ channel 1)])
            ((= channel *channels*) 0)
          (channel-set! lines (make-vector line-size 0.0)))
        (~<
         (when(zero? channel)
           (set! cursor (mod (+ cursor 1) line-size)))
         (let ([line (channel-ref lines)]
               [x (<~ signal)]
               [delay (flonum->fixnum (round (* (<~ delay) *sample-rate*)))]
               [feedback (<~ feedback)])
           (let* ([i (mod (+ line-size (- cursor delay)) line-size)]
                  [y (vector-ref line i)]
                  [z (+ x (* feedback y))])
             (vector-set! line cursor z)
             z))))))

  (define echo (make-echo *max-line-duration-fast*))
  (define echo* (make-echo *max-line-duration-slow*))
  ;; </echo>
#+END_SRC

#+NAME: lpf
#+BEGIN_SRC scheme
  ;; <lpf>
  (define (lpf-frequency->α frequency)
    (let ([k (* frequency *sample-angular-period*)])
      (/ k (+ k 1))))

  (define (lpf frequency x)
    (let ([ys (make-channel-vector 0.0)])
      (~<
       (let* ([y-1 (channel-ref ys)]
              [α (lpf-frequency->α (<~ frequency))])
         (let ([y (+ y-1 (* α (- (<~ x) y-1)))])
           (channel-set! ys y)
           y)))))
  ;; </lpf>
#+END_SRC

#+NAME: hpf
#+BEGIN_SRC scheme
  ;; <hpf>
  (define (hpf-frequency->α frequency)
    (let ([k (* frequency *sample-angular-period*)])
      (/ (+ k 1))))

  (define (hpf frequency x)
    (let ([xs (make-channel-vector 0.0)]
          [ys (make-channel-vector 0.0)])
      (~<
       (let ([x-1 (channel-ref xs)]
             [y-1 (channel-ref ys)]
             [x (<~ x)]
             [α (hpf-frequency->α (<~ frequency))])
         (let ([y (* α (+ y-1 (- x x-1)))])
           (channel-set! xs x)
           (channel-set! ys y)
           y)))))
  ;; </hpf>
#+END_SRC

#+NAME: make-biquad-filter
#+BEGIN_SRC scheme
  ;; <make-biquad-filter>
  (define (make-biquad-filter make-coefficients)
    (λ (Q frequency x)
      (let ([xs-1 (make-channel-vector 0.0)]
            [xs-2 (make-channel-vector 0.0)]
            [ys-1 (make-channel-vector 0.0)]
            [ys-2 (make-channel-vector 0.0)])
        (~<
         (let ([x-1 (channel-ref xs-1)]
               [x-2 (channel-ref xs-2)]
               [y-1 (channel-ref ys-1)]
               [y-2 (channel-ref ys-2)]
               [x (<~ x)]
               [Q (<~ Q)]
               [frequency (<~ frequency)])
           (let* ([ω (* frequency *sample-angular-period*)]
                  [sin-ω (sin ω)]
                  [cos-ω (cos ω)]
                  [α (/ sin-ω (* 2.0 Q))])
             (let-values ([(b0 b1 b2 a0 a1 a2) (make-coefficients sin-ω cos-ω α)])
               (let ([y (-
                         (+
                          (* (/ b0 a0) x)
                          (* (/ b1 a0) x-1)
                          (* (/ b2 a0) x-2))
                         (* (/ a1 a0) y-1)
                         (* (/ a2 a0) y-2))])
                 (channel-set! xs-1 x)
                 (channel-set! xs-2 x-1)
                 (channel-set! ys-1 y)
                 (channel-set! ys-2 y-1)
                 y))))))))
  ;; </make-biquad-filter>
#+END_SRC

#+NAME: biquad-lpf
#+BEGIN_SRC scheme
  ;; <biquad-lpf>
  (define (make-lpf-coefficients sin-ω cos-ω α)
    (let ([b0 (* 0.5 (- 1.0 cos-ω))])
      (values
       b0             ;; b0
       (- 1.0 cos-ω)  ;; b1
       b0             ;; b2
       (+ 1.0 α)      ;; a0
       (* -2.0 cos-ω) ;; a1
       (- 1.0 α)      ;; a2
       )))

  (define biquad-lpf (make-biquad-filter make-lpf-coefficients))
  ;; </biquad-lpf>
#+END_SRC

#+NAME: biquad-hpf
#+BEGIN_SRC scheme
  ;; <biquad-hpf>
  (define (make-hpf-coefficients sin-ω cos-ω α)
    (let ([b0 (* 0.5 (+ 1.0 cos-ω))])
      (values
       b0             ;; b0
       (- -1.0 cos-ω) ;; b1
       b0             ;; b2
       (+ 1.0 α)      ;; a0
       (* -2.0 cos-ω) ;; a1
       (- 1.0 α)      ;; a2
       )))

  (define biquad-hpf (make-biquad-filter make-hpf-coefficients))
  ;; </biquad-hpf>
#+END_SRC

** Instruments

#+NAME: polyphony
#+BEGIN_SRC scheme
  ;; <polyphony>
  (define (make-polyphony n make-voice)
    (let ([voices (make-vector n ∅)]
          [cursor 0])
      (let ([signal
             (apply mix (list-ec (: i n) (~< (<~ (vector-ref voices i)))))]
            [play-note
             (λ args
               (let ([voice (apply make-voice args)])
                 (vector-set! voices cursor voice)
                 (set! cursor (mod (+ cursor 1) n))
                 voice))])
        (values signal play-note))))

  (define (make-static-polyphony n make-voice)
    ;; (make-voice) -> (list signal play-note)
    (let ([voices (list-ec (: i n) (make-voice))]
          [cursor 0])
      (let ([signal (apply mix (map first voices))]
            [play-note
             (λ args
               (apply (second (vector-ref voices cursor)) args)
               (set! cursor (mod (+ cursor 1) n)))])
        (values signal play-note))))
  ;; </polyphony>
#+END_SRC


** Scales

   We are going to represent scales with Scheme's basic data structure, list.
   And the most basic operation which we want to perform on scale is chosing a
   note from it without worrying about falling out of range:

#+NAME: choice
#+BEGIN_SRC scheme
  ;; <choice>
  (define (choice list n)
    (list-ref list (mod n (length list))))

  (define (random-choice list)
    (list-ref list (random (length list))))
  ;; </choice>
#+END_SRC

  Basic intervals from Western music.

#+NAME: intervals
#+BEGIN_SRC scheme
  ;; <intervals>
  (define chromatic-scale-half-step
    (expt 2 1/12))

  (define second-interval (expt chromatic-scale-half-step 2))
  (define third-interval (expt chromatic-scale-half-step 4))
  (define perfect-fourth-interval (expt chromatic-scale-half-step 5))
  (define perfect-fifth-interval (expt chromatic-scale-half-step 7))
  (define major-sixth-interval (expt chromatic-scale-half-step 9))
  (define major-seventh-interval (expt chromatic-scale-half-step 11))
  (define perfect-octave-interval (expt chromatic-scale-half-step 12))
  (define minor-second-interval (expt chromatic-scale-half-step 1))
  (define minor-third-interval (expt chromatic-scale-half-step 3))
  (define minor-sixth-interval (expt chromatic-scale-half-step 8))
  (define minor-seventh-interval (expt chromatic-scale-half-step 11))
  (define triton-interval (expt chromatic-scale-half-step 11))
  ;; </intervals>
#+END_SRC

  Some basic scales from Western music.

#+NAME: scales
#+BEGIN_SRC scheme
  ;; <scales>
  (define chromatic-scale '(1 2 3 4 5 6 7 8 9 10 11 12))
  (define pentatonic-scale '(1 3 5 8 10))
  (define major-scale '(1 3 5 6 8 10 12))
  (define minor-scale '(1 3 4 6 8 9 11))

  (define (make-scale base-frequency scale)
    (map (λ (x) (* base-frequency (expt chromatic-scale-half-step (- x 1)))) scale))
  ;; </scales>
#+END_SRC

** Rhythm

#+NAME: pattern
#+BEGIN_SRC scheme
  ;; <pattern>
  (define (play-pattern pattern sound beat)
    (let ([n (length pattern)])
      (when (positive? (choice pattern (exact beat)))
        (sound))))
  ;; </pattern>
#+END_SRC

** MIDI

#+NAME: midi
#+BEGIN_SRC scheme
  ;; <midi>
  (define (*on-note-on* timestamp data1 data2 channel)
    (printf "~s:~s:~s:~s\r\n" timestamp data1 data2 channel))

  (define (*on-note-off* timestamp data1 data2 channel)
    (printf "~s:~s:~s:~s\r\n" timestamp data1 data2 channel))

  (define (*on-cc* timestamp data1 data2 channel)
    (printf "~s:~s:~s:~s\r\n" timestamp data1 data2 channel))

  (define (set-note-on! f) (set! *on-note-on* f))
  (define (set-note-off! f) (set! *on-note-off* f))
  (define (set-cc! f) (set! *on-cc* f))

  (define *polling-cycle* 0.005)

  (define *stream* #f)
  (define *scheduler* #f)

  (define (process-event timestamp type data1 data2 channel)
    (cond
      [(= type pm:*midi-note-on*) (*on-note-on* timestamp data1 data2 channel)]
      [(= type pm:*midi-note-off*) (*on-note-off* timestamp data1 data2 channel)]
      [(= type pm:*midi-cc*) (*on-cc* timestamp data1 data2 channel)]
      [else (printf "Unsupported event type: ~s\r\n" type)]))

  (define (make-safe-process-event timestamp)
    (lambda args
      (guard (_ [else #f]) (apply process-event timestamp args))))

  (define (process-events)
    (let ([timestamp (scheduler:now *scheduler*)])
      (when (pm:poll *stream*)
        (pm:read *stream* (make-safe-process-event timestamp)))
      (scheduler:schedule *scheduler*
                          (+ timestamp *polling-cycle*)
                          process-events)))

  (define (start now)
    (unless *stream*
      (pm:init)
      (set! *stream* (pm:open-input 0))
      (set! *scheduler* (scheduler:simple-scheduler now))
      (scheduler:start-scheduler *scheduler*)
      (process-events)))

  (define (stop)
    (when *stream*
      (scheduler:stop-scheduler *scheduler*)
      (pm:close *stream*)
      (pm:terminate)
      (set! *stream* #f)
      (set! *scheduler* #f)))
  ;; </midi>
#+END_SRC
* Misc

  To import =chez-soundio= and =chez-sockets= we must add respective folders to
  =library-directories= To do that let's create a couple of helpers:

#+NAME: add-library-directories
#+BEGIN_SRC scheme
  ;; <add-library-directories>
  (define (add-library-directory dir)
    (library-directories
     (cons dir (library-directories))))

  (define (add-library-directories . dirs)
    (unless (null? dirs)
      (add-library-directory (car dirs))
      (apply add-library-directories (cdr dirs))))

  (add-library-directories
   "./chez-soundio"
   "./chez-portmidi"
   "./chez-sockets")
  ;; </add-library-directories>
#+END_SRC

  Also let's define several useful aliases and finally start our services:

#+NAME: ad-libitum-init
#+BEGIN_SRC scheme
  ;; <ad-libitum-init>
  (alias now sound:now)
  (alias schedule scheduler:*schedule*)
  (alias callback schedule)

  ;; in case of emergency ☺
  (alias hush! sound:hush!)
  (alias h! hush!)

  (alias play! sound:set-dsp!)

  (sound:start)
  (scheduler:init now)
  (scheduler:start)
  ;; (repl:start-repl-server)
  ;; </ad-libitum-init>
#+END_SRC

  Tuner stuff to test everything is working:

#+NAME: test-tuner
#+BEGIN_SRC scheme
  ;; <test-tuner>
  (define (tuner time channel)
    (sin (* 2π time tuner-frequency)))

  (define (quick-test signal)
    (signal (random 1.0) (random *channels*)))

  ;; (sound:set-dsp! tuner)
  ;; </test-tuner>
#+END_SRC

  Some useful conversions, see TTEM.org for more details.

#+NAME: unit-conversion
#+BEGIN_SRC scheme
  (define (amp->dB x)
    (* 20.0 (log x 10.0)))

  (define (dB->amp x)
    (expt 10.0 (/ x 20.0)))

  (define (midi-pitch->frequency m)
    (* 440.0 (expt 2.0 (/ (- m 69.0) 12.0))))

  (define (frequency->midi-pitch f)
    (+ 69 (exact (round (* 12.0 (log (/ f 440.0) 2.0))))))
#+END_SRC

  Some stuff about time and scales to be moved to appropriate sections when
  we'll come to them:

#+NAME: sandbox
#+BEGIN_SRC scheme
  ;; <sandbox>
  (define (make-overtone amplitudes wave frequency phase0)
    (∑ (map
        (λ (amplitude factor)
          (let ([factor (inexact factor)])
            (*~ amplitude
                (wave (osc:phasor (*~ (~< factor) frequency) phase0)))))
        amplitudes
        (iota (length amplitudes)))))

  (define (fix-duration duration)
    (let* ([start (now)]
           [end (+ start duration)])
      (values (~< start) (~< end))))
  ;; </sandbox>
#+END_SRC

* Files :noexport:

#+NAME: ad-libitum.ss
#+BEGIN_SRC scheme :tangle ad-libitum.ss :noweb yes :mkdirp yes :paddle no
  <<add-library-directories>>

  (import (ad-libitum common))

  (voodoo)

  (import (chezscheme)
          (srfi s1 lists)
          (srfi s26 cut)
          (srfi s42 eager-comprehensions)
          (ad-libitum signal)
          (prefix (ad-libitum control) ctrl:)
          (prefix (ad-libitum oscillator) osc:)
          (prefix (ad-libitum envelope) env:)
          (prefix (ad-libitum filter) filter:)
          (prefix (ad-libitum scale) scale:)
          (prefix (ad-libitum instrument) inst:)
          (ad-libitum metro)
          (prefix (ad-libitum noise) noise:)
          (prefix (ad-libitum sound) sound:)
          (prefix (ad-libitum scheduler) scheduler:)
          (prefix (ad-libitum repl) repl:)
          (prefix (ad-libitum midi) midi:)
          )

  <<ad-libitum-init>>
  <<tuner-constants>>
  <<test-tuner>>
#+END_SRC

#+NAME: common.ss
#+BEGIN_SRC scheme :tangle ad-libitum/common.ss :noweb yes :mkdirp yes :paddle no
  #!chezscheme
  (library (ad-libitum common (1))
    (export voodoo λ id >>> >> -> ->>
            compose ∘ pi two-pi π 2π clamp
            choice random-choice
            random-amplitude
            amp->dB dB->amp midi-pitch->frequency frequency->midi-pitch
            *channels* *sample-rate* *sample-angular-period*)
    (import (chezscheme)
            (only (srfi s1 lists) reduce)
            (srfi s26 cut)
            (prefix (ad-libitum sound) sound:))

    (alias *sample-rate* sound:*sample-rate*)
    (alias *channels* sound:*channels*)

    (define (voodoo)
      (collect-maximum-generation 6)
      (collect-generation-radix 2)
      ;; (eval-when (compile) (optimize-level 3))
      (optimize-level 2)
      )

    ;; symbols
    (alias λ lambda)

    ;; can't live without
    (define (id x) x)

    <<compose>>
    <<basic-math>>
    <<unit-conversion>>
    <<choice>>

    (define *sample-angular-period* (/ 2π *sample-rate*))

    ;; threading

    (define-syntax (>>> stx)
      (syntax-case stx ()
        [(_ it x) #'x]
        [(_ it x (y ...) rest ...)
         #'(let ([it x])
             (>>> it (y ...) rest ...))]))

    (define-syntax (>> stx)
      (syntax-case stx ()
        [(k rest ...)
         (with-syntax ([^ (datum->syntax #'k '^)])
           #'(>>> ^ rest ...))]))

    (define-syntax ->
      (syntax-rules ()
        [(_ x) x]
        [(_ x (y z ...) rest ...)
         (-> (y x z ...) rest ...)]))

    (define-syntax ->>
      (syntax-rules ()
        [(_ x) x]
        [(_ x (y ...) rest ...)
         (->> (y ... x) rest ...)])))
#+END_SRC

#+NAME: signal.ss
#+BEGIN_SRC scheme :tangle ad-libitum/signal.ss :noweb yes :mkdirp yes :paddle no
  #!chezscheme
  (library (ad-libitum signal (1))
    (export signal ~< <~ define-signal define~
            make-channel-vector channel-ref channel-set!
            constant silence ∅ unit
            mono
            live-signal live-value
            signal-sum signal-prod signal-diff signal-div
            +~ *~ -~ /~ ∑ ∏ mix pan phase->interval amplitude->phase)
    (import (chezscheme)
            (srfi s26 cut)
            (ad-libitum common))
    <<signal>>
    <<channel>>
    <<constant>>
    <<silence>>
    <<unit>>
    <<deref-signal>>
    <<mono>>
    <<live-signal>>
    <<live-value>>
    <<signal-operators>>
    )
#+END_SRC

#+NAME: oscillator.ss
#+BEGIN_SRC scheme :tangle ad-libitum/oscillator.ss :noweb yes :mkdirp yes :paddle no
  #!chezscheme
  (library (ad-libitum oscillator (1))
    (export phasor ///
            sine cosine square pulse tri saw sampler unroll
            sine/// cosine/// square/// pulse/// tri/// saw/// sampler///
            )
    (import (chezscheme)
            (srfi s42 eager-comprehensions)
            (ad-libitum common)
            (ad-libitum signal))

    <<phasor>>
    <<waveforms>>
    )
#+END_SRC

#+NAME: noise.ss
#+BEGIN_SRC scheme :tangle ad-libitum/noise.ss :noweb yes :mkdirp yes :paddle no
  (library (ad-libitum noise (1))
    (export white)
    (import (chezscheme)
            (ad-libitum common)
            (ad-libitum signal))

    (define~ white (random-amplitude))
    )
#+END_SRC

#+NAME: envelope.ss
#+BEGIN_SRC scheme :tangle ad-libitum/envelope.ss :noweb yes :mkdirp yes :paddle no
  (library (ad-libitum envelope (1))
    (export adsr impulse
            transition instant-transition linear-transition quadratic-transition
            )
    (import (chezscheme)
            (srfi s26 cut)
            (ad-libitum common)
            (ad-libitum signal)
            (only (ad-libitum sound) now)
            )
    <<adsr>>
    <<impulse>>
    <<transition>>
    )
#+END_SRC

#+NAME: scale.ss
#+BEGIN_SRC scheme :tangle ad-libitum/scale.ss :noweb yes :mkdirp yes :paddle no
  (library (ad-libitum scale (1))
    (export chromatic-scale-half-step
            second-interval
            third-interval
            perfect-fourth-interval
            perfect-fifth-interval
            major-sixth-interval
            major-seventh-interval
            perfect-octave-interval
            minor-second-interval
            minor-third-interval
            minor-second-interval
            triton-interval
            chromatic-scale
            pentatonic-scale
            major-scale
            minor-scale
            make-scale
            )
    (import (chezscheme)
            (ad-libitum common))
    <<intervals>>
    <<scales>>
    )
#+END_SRC

#+NAME: control.ss
#+BEGIN_SRC scheme :tangle ad-libitum/control.ss :noweb yes :mkdirp yes :paddle no
  #!chezscheme
  (library (ad-libitum control (1))
    (export make-control define-control window)
    (import (chezscheme)
            (srfi s42 eager-comprehensions)
            (ad-libitum common)
            (ad-libitum signal)
            )
    <<control-signal>>
    <<window>>
    )
#+END_SRC

#+NAME: instrument.ss
#+BEGIN_SRC scheme :tangle ad-libitum/instrument.ss :noweb yes :mkdirp yes :paddle no
  (library (ad-libitum instrument (1))
    (export make-polyphony)
    (import (chezscheme)
            (only (srfi s1 lists) first second)
            (srfi s42 eager-comprehensions)
            (ad-libitum common)
            (ad-libitum signal))
    <<polyphony>>
    )
#+END_SRC

#+NAME: filter.ss
#+BEGIN_SRC scheme :tangle ad-libitum/filter.ss :noweb yes :mkdirp yes :paddle no
  (library (ad-libitum filter (1))
    (export delay
            echo echo*
            lpf
            hpf
            biquad-lpf
            biquad-hpf)
    (import (except (chezscheme) delay)
            (ad-libitum common)
            (ad-libitum signal))
    <<delay>>
    <<echo>>
    <<lpf>>
    <<hpf>>
    <<make-biquad-filter>>
    <<biquad-lpf>>
    <<biquad-hpf>>
    )
#+END_SRC

#+NAME: metro.ss
#+BEGIN_SRC scheme :tangle ad-libitum/metro.ss :noweb yes :mkdirp yes :paddle no
  (library (ad-libitum metro (1))
    (export metro *metro* *beat* play-pattern time->beat beat->time set-bpm!)
    (import (chezscheme)
            (ad-libitum common)
            (only (ad-libitum sound) now)
            (rename (only (ad-libitum scheduler) *schedule*)
                    (*schedule* schedule)))
    <<beat>>
    <<pattern>>
    )
#+END_SRC

#+NAME: sound.ss
#+BEGIN_SRC scheme :tangle ad-libitum/sound.ss :noweb yes :mkdirp yes :paddle no
  (library (ad-libitum sound (1))
    (export start stop set-dsp! hush! *sample-rate* *channels* now)
    (import (chezscheme) (prefix (soundio) soundio:))
    <<sound>>
    )
#+END_SRC

#+NAME: scheduler.ss
#+BEGIN_SRC scheme :tangle ad-libitum/scheduler.ss :noweb yes :mkdirp yes :paddle no
  (library (ad-libitum scheduler (1))
    (export start stop init
            start-scheduler stop-scheduler schedule now
            simple-scheduler
            *schedule* *now*)
    (import (chezscheme)
            (only (soundio) usleep))
    <<pairing-heap>>
    <<scheduler>>
    <<easy-scheduler>>
    )
#+END_SRC

#+BEGIN_SRC scheme :tangle ad-libitum/repl.ss :noweb yes :mkdirp yes :paddle no
  (library (ad-libitum repl (1))
    (export start-repl-server)
    (import (chezscheme)
            (only (soundio) usleep)
            (prefix (bsd-sockets) sock:))
    <<open-socket>>
    <<spawn-remote-repl>>
    <<accept-connections>>
    <<start-repl-server>>
    )
#+END_SRC

#+NAME: violet.ss
#+BEGIN_SRC scheme :tangle violet.ss :noweb yes :mkdirp yes :paddle no
  (load "ad-libitum.ss")

  <<sandbox>>
  <<simplest-oscillator>>
  <<play-note>>
#+END_SRC

#+NAME: midi.ss
#+BEGIN_SRC scheme :tangle ad-libitum/midi.ss :noweb yes :paddle no
  (library (ad-libitum midi (1))
    (export start stop set-note-on! set-note-off! set-cc!)
    (import (chezscheme)
            (prefix (ad-libitum scheduler) scheduler:)
            (prefix (portmidi) pm:))
    <<midi>>
    )
#+END_SRC

** Tests

#+NAME: test-runner.ss
#+BEGIN_SRC  scheme :tangle ad-libitum/test-runner.ss :noweb yes :mkdirp yes :paddle no
  (import
   (chezscheme)
   (srfi s42 eager-comprehensions)
   (srfi s64 testing)
   (ad-libitum common)
   (ad-libitum signal)
   )


  (define (test-on-test-end-simple runner)
    (let ((log (test-runner-aux-value runner))
          (kind (test-result-ref runner 'result-kind)))
      (if (memq kind '(fail xpass))
          (let* ((results (test-result-alist runner))
                 (source-file (assq 'source-file results))
                 (source-line (assq 'source-line results))
                 (test-name (assq 'test-name results))
                 (expected-value (assq 'expected-value results))
                 (actual-value (assq 'actual-value results))
                 )
            (if (or source-file source-line)
                (begin
                  (if source-file (display (cdr source-file)))
                  (display ":")
                  (if source-line (display (cdr source-line)))
                  (display ": ")))
            (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
            (if test-name
                (begin
                  (display " ")
                  (display (cdr test-name))))
            (newline)
            (printf "Expected: ~s\r\nActual: ~s\r\n"
                    (cdr expected-value)
                    (cdr actual-value))))
      (if (output-port? log)
          (begin
            (display "Test end:" log)
            (newline log)
            (let loop ((list (test-result-alist runner)))
              (if (pair? list)
                  (let ((pair (car list)))
                    ;; Write out properties not written out by on-test-begin.
                    (if (not (memq (car pair)
                                   '(test-name source-file source-line source-form)))
                        (%test-write-result1 pair log))
                    (loop (cdr list)))))))))

  (define (my-test-runner)
    (let ((runner (test-runner-simple)))
      (test-runner-reset runner)
      ;; (test-runner-on-group-begin! runner test-on-group-begin-simple)
      ;; (test-runner-on-group-end! runner test-on-group-end-simple)
      ;; (test-runner-on-final! runner test-on-final-simple)
      ;; (test-runner-on-test-begin! runner test-on-test-begin-simple)
      (test-runner-on-test-end! runner test-on-test-end-simple)
      ;; (test-runner-on-bad-count! runner test-on-bad-count-simple)
      ;; (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
      runner))

  (test-runner-current (my-test-runner))
#+END_SRC

#+NAME: test-oscillator.ss
#+BEGIN_SRC  scheme :tangle ad-libitum/test-oscillator.ss :noweb yes :mkdirp yes :paddle no
  (import (ad-libitum oscillator))

  (load "ad-libitum/test-runner.ss")

  (test-group
   "phasor"

   (let ([phase0 (~< 0.25)]
         [antiphase0 (~< 0.75)])
     (do-ec
      (:real-range frequency 0.0 440.0 1.23456)
      (:real-range time 0.0 1.0 0.001)
      (: channel 2)
      (test-approximate "antiphase"
        0.0
        (+ ((sine (phasor (~< frequency) phase0)) time channel)
           ((sine (phasor (~< frequency) antiphase0)) time channel))
        1e-14))))
#+END_SRC