Data

Tools

Indexes

Applications

Experiments

Awesome

An open API service indexing awesome lists of open source software.

https://github.com/ul/ad-libitum

Scheme Live Coding Environment
https://github.com/ul/ad-libitum

chez-scheme literate-programming livecoding scheme

Last synced: 3 months ago
JSON representation

Scheme Live Coding Environment

Awesome Lists containing this project

README 

        



Ad Libitum



 <!--/*--><![CDATA[/*><!--*/

  .title  { text-align: center;

             margin-bottom: .2em; }

  .subtitle { text-align: center;

              font-size: medium;

              font-weight: bold;

              margin-top:0; }

  .todo   { font-family: monospace; color: red; }

  .done   { font-family: monospace; color: green; }

  .priority { font-family: monospace; color: orange; }

  .tag    { background-color: #eee; font-family: monospace;

            padding: 2px; font-size: 80%; font-weight: normal; }

  .timestamp { color: #bebebe; }

  .timestamp-kwd { color: #5f9ea0; }

  .org-right  { margin-left: auto; margin-right: 0px;  text-align: right; }

  .org-left   { margin-left: 0px;  margin-right: auto; text-align: left; }

  .org-center { margin-left: auto; margin-right: auto; text-align: center; }

  .underline { text-decoration: underline; }

  #postamble p, #preamble p { font-size: 90%; margin: .2em; }

  p.verse { margin-left: 3%; }

  pre {

    border: 1px solid #ccc;

    box-shadow: 3px 3px 3px #eee;

    padding: 8pt;

    font-family: monospace;

    overflow: auto;

    margin: 1.2em;

  }

  pre.src {

    position: relative;

    overflow: auto;

    padding-top: 1.2em;

  }

  pre.src:before {

    display: none;

    position: absolute;

    background-color: white;

    top: -10px;

    right: 10px;

    padding: 3px;

    border: 1px solid black;

  }

  pre.src:hover:before { display: inline; margin-top: 14px;}

  /* Languages per Org manual */

  pre.src-asymptote:before { content: 'Asymptote'; }

  pre.src-awk:before { content: 'Awk'; }

  pre.src-C:before { content: 'C'; }

  /* pre.src-C++ doesn't work in CSS */

  pre.src-clojure:before { content: 'Clojure'; }

  pre.src-css:before { content: 'CSS'; }

  pre.src-D:before { content: 'D'; }

  pre.src-ditaa:before { content: 'ditaa'; }

  pre.src-dot:before { content: 'Graphviz'; }

  pre.src-calc:before { content: 'Emacs Calc'; }

  pre.src-emacs-lisp:before { content: 'Emacs Lisp'; }

  pre.src-fortran:before { content: 'Fortran'; }

  pre.src-gnuplot:before { content: 'gnuplot'; }

  pre.src-haskell:before { content: 'Haskell'; }

  pre.src-hledger:before { content: 'hledger'; }

  pre.src-java:before { content: 'Java'; }

  pre.src-js:before { content: 'Javascript'; }

  pre.src-latex:before { content: 'LaTeX'; }

  pre.src-ledger:before { content: 'Ledger'; }

  pre.src-lisp:before { content: 'Lisp'; }

  pre.src-lilypond:before { content: 'Lilypond'; }

  pre.src-lua:before { content: 'Lua'; }

  pre.src-matlab:before { content: 'MATLAB'; }

  pre.src-mscgen:before { content: 'Mscgen'; }

  pre.src-ocaml:before { content: 'Objective Caml'; }

  pre.src-octave:before { content: 'Octave'; }

  pre.src-org:before { content: 'Org mode'; }

  pre.src-oz:before { content: 'OZ'; }

  pre.src-plantuml:before { content: 'Plantuml'; }

  pre.src-processing:before { content: 'Processing.js'; }

  pre.src-python:before { content: 'Python'; }

  pre.src-R:before { content: 'R'; }

  pre.src-ruby:before { content: 'Ruby'; }

  pre.src-sass:before { content: 'Sass'; }

  pre.src-scheme:before { content: 'Scheme'; }

  pre.src-screen:before { content: 'Gnu Screen'; }

  pre.src-sed:before { content: 'Sed'; }

  pre.src-sh:before { content: 'shell'; }

  pre.src-sql:before { content: 'SQL'; }

  pre.src-sqlite:before { content: 'SQLite'; }

  /* additional languages in org.el's org-babel-load-languages alist */

  pre.src-forth:before { content: 'Forth'; }

  pre.src-io:before { content: 'IO'; }

  pre.src-J:before { content: 'J'; }

  pre.src-makefile:before { content: 'Makefile'; }

  pre.src-maxima:before { content: 'Maxima'; }

  pre.src-perl:before { content: 'Perl'; }

  pre.src-picolisp:before { content: 'Pico Lisp'; }

  pre.src-scala:before { content: 'Scala'; }

  pre.src-shell:before { content: 'Shell Script'; }

  pre.src-ebnf2ps:before { content: 'ebfn2ps'; }

  /* additional language identifiers per "defun org-babel-execute"

       in ob-*.el */

  pre.src-cpp:before  { content: 'C++'; }

  pre.src-abc:before  { content: 'ABC'; }

  pre.src-coq:before  { content: 'Coq'; }

  pre.src-groovy:before  { content: 'Groovy'; }

  /* additional language identifiers from org-babel-shell-names in

     ob-shell.el: ob-shell is the only babel language using a lambda to put

     the execution function name together. */

  pre.src-bash:before  { content: 'bash'; }

  pre.src-csh:before  { content: 'csh'; }

  pre.src-ash:before  { content: 'ash'; }

  pre.src-dash:before  { content: 'dash'; }

  pre.src-ksh:before  { content: 'ksh'; }

  pre.src-mksh:before  { content: 'mksh'; }

  pre.src-posh:before  { content: 'posh'; }

  /* Additional Emacs modes also supported by the LaTeX listings package */

  pre.src-ada:before { content: 'Ada'; }

  pre.src-asm:before { content: 'Assembler'; }

  pre.src-caml:before { content: 'Caml'; }

  pre.src-delphi:before { content: 'Delphi'; }

  pre.src-html:before { content: 'HTML'; }

  pre.src-idl:before { content: 'IDL'; }

  pre.src-mercury:before { content: 'Mercury'; }

  pre.src-metapost:before { content: 'MetaPost'; }

  pre.src-modula-2:before { content: 'Modula-2'; }

  pre.src-pascal:before { content: 'Pascal'; }

  pre.src-ps:before { content: 'PostScript'; }

  pre.src-prolog:before { content: 'Prolog'; }

  pre.src-simula:before { content: 'Simula'; }

  pre.src-tcl:before { content: 'tcl'; }

  pre.src-tex:before { content: 'TeX'; }

  pre.src-plain-tex:before { content: 'Plain TeX'; }

  pre.src-verilog:before { content: 'Verilog'; }

  pre.src-vhdl:before { content: 'VHDL'; }

  pre.src-xml:before { content: 'XML'; }

  pre.src-nxml:before { content: 'XML'; }

  /* add a generic configuration mode; LaTeX export needs an additional

     (add-to-list 'org-latex-listings-langs '(conf " ")) in .emacs */

  pre.src-conf:before { content: 'Configuration File'; }



  table { border-collapse:collapse; }

  caption.t-above { caption-side: top; }

  caption.t-bottom { caption-side: bottom; }

  td, th { vertical-align:top;  }

  th.org-right  { text-align: center;  }

  th.org-left   { text-align: center;   }

  th.org-center { text-align: center; }

  td.org-right  { text-align: right;  }

  td.org-left   { text-align: left;   }

  td.org-center { text-align: center; }

  dt { font-weight: bold; }

  .footpara { display: inline; }

  .footdef  { margin-bottom: 1em; }

  .figure { padding: 1em; }

  .figure p { text-align: center; }

  .equation-container {

    display: table;

    text-align: center;

    width: 100%;

  }

  .equation {

    vertical-align: middle;

  }

  .equation-label {

    display: table-cell;

    text-align: right;

    vertical-align: middle;

  }

  .inlinetask {

    padding: 10px;

    border: 2px solid gray;

    margin: 10px;

    background: #ffffcc;

  }

  #org-div-home-and-up

   { text-align: right; font-size: 70%; white-space: nowrap; }

  textarea { overflow-x: auto; }

  .linenr { font-size: smaller }

  .code-highlighted { background-color: #ffff00; }

  .org-info-js_info-navigation { border-style: none; }

  #org-info-js_console-label

    { font-size: 10px; font-weight: bold; white-space: nowrap; }

  .org-info-js_search-highlight

    { background-color: #ffff00; color: #000000; font-weight: bold; }

  .org-svg { width: 90%; }

  /*]]>*/-->



// @license magnet:?xt=urn:btih:e95b018ef3580986a04669f1b5879592219e2a7a&dn=public-domain.txt Public Domain

<!--/*--><![CDATA[/*><!--*/

     function CodeHighlightOn(elem, id)

     {

       var target = document.getElementById(id);

       if(null != target) {

         elem.classList.add("code-highlighted");

         target.classList.add("code-highlighted");

       }

     }

     function CodeHighlightOff(elem, id)

     {

       var target = document.getElementById(id);

       if(null != target) {

         elem.classList.remove("code-highlighted");

         target.classList.remove("code-highlighted");

       }

     }

    /*]]>*///-->

// @license-end





Ad Libitum




Table of Contents








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








1 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.










1.1 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.










1.1.1 Clone Chez Scheme repository






git clone https://github.com/racket/ChezScheme.git

cd ChezScheme














1.1.2 Configure, build and install Chez Scheme






./configure --disable-x11

make

sudo make install








The first command may suggest you to build boot image first, e.g. on M1:





./configure --pb

make tarm64osx.bootquick














1.1.3 Test it's working






Run scheme from terminal and try to evaluate simple expression:






~/ChezScheme> scheme



Chez Scheme Version 9.5.5.5

Copyright 1984-2020 Cisco Systems, Inc.



> (+ 1 2 3)

6

>
















1.2 libsoundio






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

sound system.






brew install libsoundio














1.3 PortMidi






You need it if you plan to use MIDI controller.






brew install portmidi














1.4 Ad Libitum itself










1.4.1 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/).






git clone https://github.com/ul/ad-libitum.git

cd ad-libitum

git submodule update --init --recursive --remote

make libs














1.4.2 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!






~/ad-libitum> scheme ad-libitum.ss



Chez Scheme Version 9.5.1

Copyright 1984-2017 Cisco Systems, Inc.



> (play! tuner)

>














1.4.3 Play






Run & geiser-connect






scheme --optimize-level 2 violet.ss

















2 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.












3 Kernel










3.1 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.






;; <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>














3.2 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.






;; <scheduler-interface>

<<now>>

<<schedule>>

;; </scheduler-interface>








As far as scheduler is stateful and even involves thread creation, it must

have two other basic methods:






;; <scheduler-interface>

<<start-scheduler>>

<<stop-scheduler>>

;; </scheduler-interface>








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.






;; <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>








Let's implement scheduler interface.






now then would just call now field:






;; <now>

(define (now scheduler) ((scheduler-now scheduler)))

;; </now>








Event queue accepts events which must have f with its

args to execute at time:






;; <event-record>

(define-record-type event

  (fields time f args))

;; </event-record>








For queue we need some heap implementation, I'm going to jump into 3.2.1!






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.






;; <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>








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.






;; <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>








Now it's a time for start/stop thread. Stopping thread would be just setting a

flag which I used to call "poison pill".






;; <stop-scheduler>

(define (stop-scheduler scheduler)

  (scheduler-thread-set! scheduler #f))

;; </stop-scheduler>








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).






;; <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>








;; <scheduler>

<<scheduler-record>>

<<event-record>>

<<scheduler-process-events>>

<<scheduler-interface>>

;; </scheduler>








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






(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*))












3.2.1 Pairing Heap






Wikipedia's type definition for pairing heap structure looks like Scheme's

pairs (surprise =) ). Using them implementation is quite straightforward.






;; <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>
















3.3 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

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 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.










3.3.1 TODO Ensure that protocol is TCP









3.3.2 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.












3.3.3 Open socket






;; <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>








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.






;; <bind-socket>

(sock:bind-socket socket (sock:string->internet-address "127.0.0.1:37146"))

;; </bind-socket>








And then let's listen for new connections!






;; <listen-socket>

(sock:listen-socket socket 1024)

;; </listen-socket>














3.3.4 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.






;; <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>














3.3.5 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:






;; <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>








Preparations are straightforward: define some helpers, send initial prompt,

and start loop.






;; <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>








Converting messages to bytevectors and sending to proper port is quite

tedious, let's write a couple of helpers:






;; <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>








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.






;; <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>








Our remote REPL supports multi-form messages, therefore we need inner loop to

read and process them one by one.






;; <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>








Eval and send result back, easy, huh?






;; <repl-eval-print>

(lambda (p)

  (let* (

         <<repl-eval>>

         )

    <<repl-print>>

    )

  )

;; </repl-eval-print>








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






;; <repl-eval>

[result #f]

[output

 (with-output-to-string

   (lambda ()

     (set! result (guard (x [else (display-condition x)]) (eval x)))))]

;; </repl-eval>








On the other hand, sending is quite straightforward, because we need just to

write to port provided by call-with-send-port






;; <repl-print>

(printf "| ~s\r\n" output)

(printf "< ~s\r\n" result)

(display output p)

(display result p)

(newline p)

;; </repl-print>














3.3.6 TODO Stop loop and close socket on disconnect









3.3.7 Start REPL server






;; <start-repl-server>

(define (start-repl-server)

  (accept-connections (open-socket)))

;; </start-repl-server>


















4 Core






Woohoo! Naive 3 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.










4.1 Math






Before diving into the abyss of digital music let's define several useful

basic math constants and functions.






;; <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>














4.2 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.






;; <tuner-constants>

(define tuner-frequency 440.0)

(define tuner-period (/ tuner-frequency))

(define tuner-half-period (* 0.5 tuner-period))

;; </tuner-constants>








;; <simplest-oscillator>

(define (simplest-oscillator time channel)

  (if (> (mod time tuner-period) tuner-half-period)

      1.0

      -1.0))

;; </simplest-oscillator>








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:






;; <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>








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:






;; <constant>

(define~ (constant amplitude) amplitude)

;; </constant>








Then we are able to define silence as follows:






;; <silence>

(define~ silence 0.0)

(alias ∅ silence)

;; </silence>








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






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






(define~ unit 1.0)








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.






;; <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>








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

function composition!






;; <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>








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.






(define-syntax (<~ stx)

  (syntax-case stx ()

    [(k signal)

     (with-syntax ([time (datum->syntax #'k 'time)]

                   [channel (datum->syntax #'k 'channel)])

       #'(signal time channel))]))








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.






;; <mono>

(define (mono signal)

  (let ([x 0.0])

    (~<

     (when (zero? channel)

       (set! x (<~ signal)))

     x)))

;; </mono>








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.






;; <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>








Then basic waveforms are defined in very clean way:






;; <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>








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:






;; <live-signal>

(define~ (live-signal symbol) (<~ (top-level-value symbol)))

;; </live-signal>








Also useful to have live value counterpart:






;; <live-value>

(define~ (live-value symbol) (top-level-value symbol))

;; </live-value>








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

matching.






;; <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>














4.3 Envelopes










4.3.1 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, 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:






;; <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>








Let's test it with simple note play:






;; <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>








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












4.3.2 Impulse






Another simple though useful envelope is impulse.






;; <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>














4.3.3 Transition






;; <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>
















4.4 Metronome






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






;; <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>














4.5 Control signals






;; <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>








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.






;; <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>
















5 Std










5.1 FFT








5.2 Filters






;; <delay>

(define~ (delay Δt f)

  (f (- time (<~ Δt)) channel))

;; </delay>








;; <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>








;; <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>








;; <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>








;; <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>








;; <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>








;; <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>














5.3 Instruments






;; <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>














5.4 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:






;; <choice>

(define (choice list n)

  (list-ref list (mod n (length list))))



(define (random-choice list)

  (list-ref list (random (length list))))

;; </choice>








Basic intervals from Western music.






;; <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>








Some basic scales from Western music.






;; <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>














5.5 Rhythm






;; <pattern>

(define (play-pattern pattern sound beat)

  (let ([n (length pattern)])

    (when (positive? (choice pattern (exact beat)))

      (sound))))

;; </pattern>














5.6 MIDI






;; <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>















6 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:






;; <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>








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






;; <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>








Tuner stuff to test everything is working:






;; <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>








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






(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))))))








Some stuff about time and scales to be moved to appropriate sections when

we'll come to them:






;; <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>













Author: Ruslan Prakapchuk


Created: 2021-09-20 Mon 09:10


Validate