Caesar Cipher: A Simple Encryption System in PicoLisp

Welcome to the “Classic Algorithms” series. Here we will discuss code examples from the Rosetta Code Project and explain step by step how the implementation works. Our first task will be the “Caesar Cipher”.

In this post, we will meet many of the “List and Strings” functions that we know from the Beginner’s-series.

The Task

If you want to try by yourself first, here is the task description:

Implement a Caesar cipher, both encoding and decoding. The key is an integer from 1 to 25. This cipher rotates (either towards left or right) the letters of the alphabet (A to Z). The encoding replaces each letter with the 1st to 25th next letter in the alphabet (wrapping Z to A). So key 2 encrypts “HI” to “JK”, but key 20 encrypts “HI” to “BC”.

How the Caesar Cipher encryption works

If you ever studied cryptographic algorithms, you will probably have come across the Caesar Cipher as it is easy to understand (and easy to break, too).

It is named after the Roman emperor Julius Caesar as there is some evidence that he used this encryption system to transport secret messages. For more historical background, see here.


The idea is that every letter in the alphabet is shifted by a fixed number of steps, which is the “encoding key”. For example, if the key is 2, then you write “C” for “A”, “D” for “B”, “E” for “C” and so on. At the end of the alphabet, “Y” becomes “A” and “Z” becomes “B”. Obviously it is not a very safe encryption because it’s easy to crack using statistical methods, or by checking all possible shifts.

Nevertheless, the implementation of the Caesar Cipher in PicoLisp is a nice example to start our Rosetta code series. It illustrates some interesting concepts such as circular lists, mapping, and anonymous functions. Many of the functions were already introduced in the “PicoLisp for Beginners” series, and the code is elegant and short.

Let’s go!

An intuitive approach to the algorithm

How should we implement this algorithm? It is clear that the order of the letters is very important, and it needs to be circular since the end of the alphabet should be mapped to its beginning. The picture from the cover sheet illustrates the principle very well:


The inner circle is the plain character, the outer circle is the encryption. Let’s try to implement this in PicoLisp now.

Step 1 – Creating the alphabet list

The first thing we need is the list of all alphabet characters. One main idea is to make the list “circular”, i. e. after “Z” comes “A” (like the tool on the pic above). In PicoLisp, this can be done by the . symbol, for example (1 2 3 .) or using the circ function. Let’s form the list:

The straightforward way: Of course, we can just type each letter by hand.

(setq *Letters '("A" "B" "C" ... "Z" .))

The elegent way: The solution above is quite error-prone. A better way would be to use ASCII encoding to create this list. Uppercase letters are encoded by the numbers 65 to 90. So let’s do the following:

  1. create a list from 65 to 90 using (range 65 90) –> (65 66 67 … 90).
  2. Numbers can be converted to characters by char, for example (char 65) = A. Let’s apply the char function to our list with (mapcar char (range 65 90)). –> (“A” “B” “C” … “Z”).
  3. Now make the list circular by applying the circ function to each letter. (apply circ (mapcar char(...)))
    –> (“A” “B” “C” … “Z” .), where . shows that after “Z” comes “A” again.
  4. Set this list to the global variable *Letters (with uppercase and asterisk according to naming convention).

We get:

:(setq *Letters (apply circ (mapcar char (range 65 90))))
-> ("A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" .)

Step 2 – Encoding a single character

Let’s try to get the string we want to encode. As first step, let’s convert all letters to uppercase with uppc and use the chop function to transform the string into a list of characters:

:(chop (uppc "in vino veritas")) 
->("I" "N" " " "V" "I" "N" "O" " " "V" "E" "R" "I" "T" "A" "S")

Now to encode these letters, we need to create a function that takes any character and returns the encoded one. Let’s go through it step by step.

  1. First we check if the character is within the *Letters list by using the member function, which returns the list starting from that character if it exists, otherwise NIL.

    : (member "U" *Letters)                                   
    -> ("U" "V" "W" "X" "Y" "Z" "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" .)
    : (member "D" *Letters)
    -> ("D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "A" "B" "C" .)
  2. As you can see, the member function returns the *Letters list starting at the respective letter. Now we want to get the encoded letter, which is shifted in position by the encryption code key. In order to shift the list, we use the nth function, which takes a list and integer value and returns the tail of the list starting from that value:

:(nth (member "U" *Letters) 2))
-> ("V" "W" "X" "Y" "Z" "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" .)
:(nth (member "D" *Letters) 6)
-> ("I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "A" "B" "C" "D" "E" "F" "G" "H" .)
  1. It’s getting close, but when we check the list returned by nth, we actually want the second item in the shifted list, because the nth function is only shifting by (key -1) positions. To get this second item, we use cadr, which is short for cdr and car. (Re-read this post if you’re not sure what car and cdr mean).
: (cadr (nth (member "U" *Letters) 2)))
-> "W"
: (cadr (nth (member "D" *Letters) 6))
-> "J"

Step 3 – Bringing it together

In Step 1 we chopped up the input string to a list, and in Step 2 we managed to encode each of these letters separately. Now let’s bring it together.

We want to take each letter of the input string and apply our encoding function on each single element, which is a typical application for mapcar. mapcar takes a function and a list as arguments. But what is our function? Obviously, we could define it like this:

(de encodeChar (C)
    (cadr (nth (member C *Letters) Key))) )

and hand it over to mapcar. But actually we need the encoding function only once, so it might be a better option (in terms of structure and readability) to define it as anonymous function.

As we might remember from the beginner’s tutorial, the syntax for anonymous functions is ” ‘((args) ( function )) “, so we can define it as:

:'((C) (cadr (nth (member C *Letters) Key)))

where C is the character to be encoded.

Now let’s create and test our mapcar anonymous function call on the chopped list, with key = 3:

: (setq TestStr (chop (uppc "in vino veritas")))
-> ("I" "N" " " "V" "I" "N" "O" " " "V" "E" "R" "I" "T" "A" "S")
: (mapcar '((C) (cadr (nth (member C *Letters) 3))) TestStr)
-> ("L" "Q" NIL "Y" "L" "Q" "R" NIL "Y" "H" "U" "L" "W" "D" "V")

This already looks quite promising: at least the character shifting looks correct now.

Now as last step, we need to convert these single letters back to a string, which we can do by using the pack function. We wrap it around our mapcar function and get:

: (pack (mapcar '((C) (cadr (nth (member C *Letters) 3))) TestStr))

As you can see, we “automatically” also got rid of all the NIL values that were created by whitespaces and punctuations.

Step 4 – Finishing the script

Let’s now wrap it up in a small script. We want to call it using the following syntax: ./caesar-cipher.l <plain-string> <key>, for example:

$ ./caesar-cipher.l "In vino veritas" 7

As we learned in the “A very first PicoLisp Program”-post, we can retrieve the two parameters <plain-string> and <key> using opt.

Note that opt converts to string, so we need to use the function format to convert the key from string to integer, and store both in the global variables *PlainStr and *Key:

#! /usr/bin/picolisp /usr/lib/picolisp/lib.l

# first command line parameter: plain string
(setq *PlainStr (opt))

# second command line parameter: key (integer)
(setq *Key (format (opt)))

Also we need to define the global *Letters list and f course our encoding function caesar that takes a string and a key as parameters and returns the encoded string.

(setq *Letters (apply circ (mapcar char (range 65 90))))

(de caesar (Str Key)
      (mapcar '((C) (cadr (nth (member C *Letters) Key)))
         (chop (uppc Str)) ) ) )

Then finally, we call the caesar function with the command line parameters and print out the result.

(prinl (caesar *PlainStr *Key))

After that we exit the interpreter with bye.


The final script can be downloaded from here. Steps: Download the script, for example using curl:

$ curl -o caesar-cipher.l

Make it executable:

$ chmod +x caesar-cipher.l


$ ./caesar-cipher.l "In vino veritas" 7

This was the first part of the “Rosetta code” series, I hope you liked it.

Tomorrow we will have a look a closer look at the set function in PicoLisp, as preparation for the “100 Doors Task” from the Rosetta Code.


Source link

Learn Scheme by Example: Tk GUI with Chicken Scheme

PS/Tk stands for a portable Scheme interface to the Tk GUI toolkit. It has a rich history going all the way back to Scheme_wish by Sven Hartrumpf in 1997. Wolf-Dieter Busch created a Chicken port called Chicken/Tk in 2004. It took on its current name when Nils M Holm stripped it of Chicken-isms to make it portable amongst Scheme implementations in 2006.

If you’ve ever tried to write portable Scheme, you know that, except for the most trivial of programs, it is much easier said than done. Holm’s pstk.scm had a configurable section titled NON-PORTABLE that you had to configure for your chosen implementation. It came full circle and was repackaged as a Chicken egg.

Chicken is a popular Scheme implementation that compiles Scheme to C. Eggs are Chicken-specific extenstion libraries that are stored in a centralized repository (like CPAN but for Chicken Scheme). Instead of building yet another calculator, let’s build a GUI for generating a tone.


You’ll need Chicken installed. It’s available in the repositories of most Linux distros. PS/Tk interfaces with Tk, not with C library bindings, but with a named pipe to tclsh8.6. The TCL package in most Linux distros will provide this. For Debian, I did sudo apt install chicken-bin tcl tk. Once Chicken is installed, you can use the chicken-install utility that comes with it to install the PS/Tk egg.

$ chicken-install -sudo pstk

When you think of Tk, you may think of something that looks like this:


Tk has come a long way in recent years. Tcl/Tk 8.5 and later comes with a new set of widgets built in called Tile or Ttk that can be themed. These widgets are available alongside the classic widgets, so you have to explicitly tell your app to use Ttk or else it will end up looking like it was designed for a 1980s Unix workstation.

(import pstk)

(ttk-map-widgets 'all) ; Use the Ttk widget set

(tk/wm 'title tk "Bleep")


All PS/Tk function names begin with tk/ or tk- (or ttk/ and ttk- for the few Ttk-specific functions). The doc directory in the PS/Tk GitHub repo unfortunately has not been updated since this convention was adopted. One example from the docs is start-tk which is now tk-start.

The ttk-map-widgets function is what tells Tk to use the Ttk widgets instead of the classic widgets. Tk comes with a few built-in themes. The default themes on Windows and macOS supposedly do a decent job of approximating the look of native widgets on those platforms. I don’t use either of those platforms, so I can’t verify this first hand. For some reason, the default theme on Linux is vaguely Windows 95ish. It comes with a built-in theme called clam that is supposed to provide “a look somewhat like a Linux application”. You can set this theme with (ttk/set-theme "clam"), but it’s really not that much of an improvement.

Ideally, something like gtkTtk that has GTK do the actual drawing would be integrated into Tcl/Tk and become the default on Linux. In the meantime, there are third party themes that imitate the look and feel of the most popular GTK and Qt themes. I use MATE with the Arc GTK theme, so I went with the Arc theme. There was even a Debian package for it (sudo apt install tcl-ttkthemes). We can then apply the theme system wide (echo '*TkTheme: arc' | xrdb -merge -), so that all Tk apps such as git-gui also inherit the theme. It is probably better to give your Linux users instructions on how to install their own theme instead of hard coding one with ttk/set-theme, so they can choose one that matches their system theme (KDE users might pick Breeze while Ubuntu users might opt for Yaru). The screenshots in this tutorial use the Arc theme.

We set the window title with tk/wm and start the event loop with tk-event-loop. We now have an empty window. Now let’s add some widgets to this window.

(define slider (tk 'create-widget 'scale 'from: 20 'to: 20000))
(slider 'set 440)
(tk/grid slider 'row: 0 'columnspan: 3 'sticky: 'ew 'padx: 20 'pady: 20)

Widgets are organized hierarchically. This is done by invoking a parent widget with the sub-command create-widget. PS/Tk associates a widget named tk with the top-level window, so most widgets will start as a call to tk (e.g. (tk 'create-widget 'label 'text: "Hello, World!")). Options are quoted and get a trailing colon (e.g. 'text: "Hello, World!").

Creating a widget returns a Scheme function. If you give this function a name, you can call it with sub-commands such as configure, get, and set. Just creating a widget doesn’t make it appear on screen. For that you need a geometry manager, of which Tk has three: the packer, the gridder, and the placer (tk/pack, tk/grid, and tk/place in Scheme, respectively).

The range of frequencies audible by humans is typically between 20 Hz and 20 KHz (we lose the ability to hear some of those higher frequencies as we age). The musical note A above middle C is 440 Hz. Since A4 serves as a general tuning standard, it seems like a sensible default, but if you run the above in Chicken, this is what you’ll see:


The scale of 20 to 20,000 is so large that 440 doesn’t appear to move the slider at all. Ideally, 440 would fall about the middle of the slider. To achieve this, let’s use a logarithmic scale.

I found a Stack Overflow answer on how to map a slider to a logarithmic scale. The code given in the answer is JavaScript, but it was easy enough to port to Scheme.

; Scale used by slider
(define *min-position* 0)
(define *max-position* 2000)
; Range of frequencies
(define *min-frequency* 20)
(define *max-frequency* 20000)

; Logarithmic scale for frequency (so middle A [440] falls about in the middle)
; Adapted from

(define min-freq (log *min-frequency*))
(define max-freq (log *max-frequency*))
(define frequency-scale (/ (- max-freq min-freq) (- *max-position* *min-position*)))
; Convert slider position to frequency
(define (position->frequency position)
  (round (exp (+ min-freq (* frequency-scale (- position *min-position*))))))
; Convert frequency to slider position
(define (frequency->position freq)
  (round (/ (- (log freq) min-freq) (+ frequency-scale *min-position*))))

I added some global parameters to the top of the script. The variable name *min-position* is just a Lisp naming convention for global parameters. I came up with the range of 0-2,000 by trial and error. It seemed to strike the best balance between each step of the slider making a noticeable change to the frequency while still allowing the user to narrow in on a specific frequency with just the slider.

Then we create two functions: one that takes the position on the slider and returns the frequency (position->frequency) and another that takes a frequency and returns the position on the slider (frequency-position). Now let’s set the initial position of our slider with the frequency->position function:

(define slider (tk 'create-widget 'scale 'from: *min-position* 'to: *max-position*))
(slider 'configure 'value: (frequency->position 440))

Underneath the slider is a spin box showing the current frequency and buttons to increase/decrease the frequency by one octave.

; Create a spin box with a units label
; Returns frame widget encompassing both spin box and label and the spin box
; widget itself. This way you can access the value of the spin box.
; e.g. (define-values (box-with-label just-box) (units-spinbox 1 12 6 "inches"))
(define (units-spinbox from to initial units)
  (let* ((container (tk 'create-widget 'frame))
         (spinbox (container 'create-widget 'spinbox 'from: from 'to: to
                             'width: (+ 4 (string-length (number->string to)))))
         (label (container 'create-widget 'label 'text: units)))
    (spinbox 'set initial)
    (tk/pack spinbox label 'side: 'left 'padx: 2)
    (values container spinbox)))

(define lower-button (tk 'create-widget 'button 'text: "<"))
(define-values (frequency-ext frequency-int)
  (units-spinbox *min-frequency* *max-frequency* 440 "Hz"))
(define higher-button (tk 'create-widget 'button 'text: ">"))

(tk/grid lower-button 'row: 1 'column: 0 'padx: 20 'pady: 20)
(tk/grid frequency-ext 'row: 1 'column: 1 'padx: 20 'pady: 20)
(tk/grid higher-button 'row: 1 'column: 2 'padx: 20 'pady: 20)

The frame widget is an invisible widget that helps with layout. Since all I need to arrange within the frame is a spin box and a label, I used tk/pack to pack them side by side. The frame is then organized in a grid with the rest of the widgets. I created a function that I can reuse later to generate the spin box, label, and frame all together. At this point, we are starting to have a nice looking interface, but it doesn’t do anything. If you click the buttons or slide the slider, nothing happens. The widgets have a command option that wires the widget up to a function. If we add a command to the slider, that command will be called each time the slider is moved.

(define slider (tk 'create-widget 'scale 'from: *min-position* 'to: *max-position*
                   'command: (lambda (x) (frequency-int 'set (position->frequency x)))))

The command for the slider takes one argument that indicates the new value of the slider. The spin box does have a command option, but the command is only called when the value is changed by clicking the up or down arrow, not when the value is changed by other means such as typing a frequency into the field. Tk has a bind command (the Scheme tk/bind function) that allows binding functions to an event on a widget. We’ll bind our callback to the KeyRelase event. The tk/bind function takes up to three arguments. The first is the widget to bind to (or a tag created with tk/bindtags to apply the binding to multiple widgets). The second is the event pattern. The event pattern is surrounded by angle brackets and can specify modifiers, event types, and more. You can find detailed documentation on the event pattern in the Tcl/Tk documentation. The third is a lambda expression to associate with the event.

(tk/bind frequency-int '<KeyRelease> (lambda ()
  ; If frequency value is a valid number, set slider to current value
  (let ((numified (string->number (frequency-int 'get))))
    (when numified
      (slider 'configure 'value: (frequency->position numified))))))

Wire the buttons up to callback functions called decrease-octave and increase-octave. An octave is “the interval between one musical pitch and another with double its frequency.”

; Set frequency slider and display
(define (set-frequency freq)
  (when (and (>= freq *min-frequency*) (<= freq *max-frequency*))
    (slider 'configure 'value: (frequency->position freq))
    (frequency-int 'set freq)))

; Buttons increase and decrease frequency by one octave
(define (adjust-octave modifier)
  (set-frequency (* (string->number (frequency-int 'get)) modifier)))
(define (decrease-octave) (adjust-octave 0.5))
(define (increase-octave) (adjust-octave 2))

If you slide the slider, the text field updates accordingly. If you type a number in the text field, the slider updates accordingly. All good, right? What if a user (and you know they will) enters a number higher than 20,000 or a letter?

Let’s extend the function that returns our labeled spin box to bind a validation function to the FocusOut event on the spin box. The spin box does have a validatecommand option, but I wasn’t able to get it working. I looked through the examples that have come with the various variations of PS/Tk and couldn’t find a single example of a spin box with a validatecommand. I even looked at the source code for Bintracker, a chiptune audio workstation written in Chicken Scheme with a PS/Tk GUI and developed by the current maintainer of the PS/Tk egg. Even it binds a validate-new-value function to the Return and FocusOut events of the spin box rather than using validatecommand.

; Create a spin box with a units label
; Returns frame widget encompassing both spin box and label and the spin box
; widget itself. This way you can access the value of the spin box.
; e.g. (define-values (box-with-label just-box) (units-spinbox 1 12 6 "inches"))
(define (units-spinbox from to initial units)
  (let* ((container (tk 'create-widget 'frame))
         (spinbox (container 'create-widget 'spinbox 'from: from 'to: to
                             'width: (+ 4 (string-length (number->string to)))))
         (label (container 'create-widget 'label 'text: units)))
    (spinbox 'set initial)
    (tk/bind spinbox '<FocusOut> (lambda ()
      (let ((current-value (string->number (spinbox 'get))))
        (unless (and current-value
                     (>= current-value from)
                     (<= current-value to))
          (spinbox 'set from)
          ; Also reset slider position to make sure it still matches display
          (slider 'configure 'value: (frequency->position (string->number (frequency-int 'get))))))))
    (tk/pack spinbox label 'side: 'left 'padx: 2)
    (values container spinbox)))

We’ll also use this function to create a field to specify the duration of the beep in milliseconds:

(define-values (duration-ext duration-int) (units-spinbox 1 600000 200 "ms"))
(tk/grid duration-ext 'row: 2 'column: 0 'padx: 20 'pady: 20)

Frequency is rather abstract. Let’s also give the user the ability to select a musical note. We can store the corresponding frequencies for A4-G4 in an association list.

; Notes -> frequency (middle A-G [A4-G4])
(define notes '(("A" 440.00)
                ("B" 493.88)
                ("C" 261.63)
                ("D" 293.66)
                ("E" 329.63)
                ("F" 349.23)
                ("G" 292.00)))

We’ll give the user a drop-down menu. Whenever a note is selected from the drop-down menu, we’ll look up the frequency in the association list and set it using the set-frequency helper function we created for the octave buttons.

(define note-frame (tk 'create-widget 'frame))
(define note (note-frame 'create-widget 'combobox 'width: 2 'values: '("A" "B" "C" "D" "E" "F" "G")))
(tk/bind note '<<ComboboxSelected>> (lambda () (set-frequency (cadr (assoc (note 'get) notes)))))
(define note-label (note-frame 'create-widget 'label 'text: "♪"))
(tk/pack note-label note 'side: 'left 'padx: 2)
(tk/grid note-frame 'row: 2 'column: 2 'padx: 20 'pady: 20)

Now, let’s make some noise. There are Chicken Scheme bindings to the Allegro library. Allegro is a library primarily used by games for cross-platform graphics, input devices, and more. What we’re interested in is the audio addon that can be used to generate a tone with a sine wave. You’ll need to install the Allegro library. Make sure you also install the header files. In some Linux distros, these are split into a separate package (e.g. liballegro5-dev on Debian). Also, install the Allegro egg (chicken-install -sudo allegro). I added the following lines near the top to import the Allegro bindings (and the chicken memory module, which we’ll also use) and initialize Allegro.

(import (prefix allegro "al:"))
(import (chicken memory))

(define +pi+ 3.141592)

; Initialize Allegro and audio addon
(unless (al:init) (print "Could not initialize Allegro."))
(unless (al:audio-addon-install) (print "Could not initialize sound."))
(al:reserve-samples 0)

The Allegro egg is accompanied by a couple of examples but no examples showing the use of the audio addon. The Allegro library itself comes with an example showing how to generate a saw wave, but being a C library, the example is, of course, in C. I ported that example to Scheme. I would have contributed the example back to the Allegro egg, but the repo is marked as “archived by the owner” and read-only on GitHub. I’ve included the example in the repo alongside the rest of the code for this tutorial in case someone finds it useful.

Allegro is very low-level. You create an audio stream. In this case, the stream buffers eight fragments of 1,024 samples each at a frequency (often called sampling rate) of 44,100 Hz (the sampling rate of an audio CD), which means there are 44,100 samples per second. Each sample is a 32-bit float (what is called the bit depth of the audio), and we only have one channel to keep things as simple as possible.

; Generate a tone using Allegro
(define (generate-tone frequency duration)
  (let* ((samples-per-buffer 1024)
         (stream-frequency 44100)
         (amplitude 0.5)
         (stream (al:make-audio-stream 8 samples-per-buffer stream-frequency 'float32 'one))
         (queue (al:make-event-queue))
         (event (al:make-event)))

    (unless (al:audio-stream-attach-to-mixer! stream (al:default-mixer))
      (print "Could not attach stream to mixer."))
    (al:event-queue-register-source! queue (al:audio-stream-event-source stream))

    (let event-loop ((n 0))
      ; Grab and handle events
      (when (and (< n (/ (* (/ duration 1000) stream-frequency) samples-per-buffer))
                 (al:event-queue-wait! queue event))
        (case (al:event-type event) ('audio-stream-fragment
          (let ((buffer (al:audio-stream-fragment stream)))
            ; If the stream is not ready for new data, buffer will be null.
            (if (not buffer) (event-loop n) (begin
              (fill-buffer buffer n) ; Placeholder
              ; Repeat
              (event-loop (+ n 1)))))))))

    (al:audio-stream-drain stream)))

An event loop waits for the audio stream to ask for another buffer. Our job is to fill that buffer with 1,024 32-bit floats at a time. In the code listing above, this is done by fill-buffer. That was just a placeholder, so I could break the code up into shorter, more easily explainable chunks. This is what goes in the place of (fill-buffer buffer n):

(let ((adr (pointer->address buffer)))
  (let loop ((i 0))
    (when (< i samples-per-buffer)
      (let ((time (/ (+ (* samples-per-buffer n) i) stream-frequency)))
        ; al:audio-stream-fragment returns a C pointer. Use (chicken
        ; memory) module to operate on foreign pointer objects.
        ; Iterate over array four bytes at a time since 32-bit depth.
        (pointer-f32-set! (address->pointer (+ adr (* i 4)))
          (* amplitude (sin (* 2 +pi+ frequency time))))
        (loop (+ i 1)))))
  (unless (al:audio-stream-fragment-set! stream buffer)
    (print "Error setting stream fragment")))

The Allegro egg is a pretty thin wrapper of the Allegro library. The audio-stream-fragment procedure in the egg just passes along the C pointer that the corresponding al_get_audio_stream_fragment function from the C library returns. It would have been nice if the egg had offered some Scheme conveniences atop Allegro like allowing us to pass a Scheme list or array to Allegro to provide the buffer of samples. Since it doesn’t, we’ll use the chicken memory module to fill the C array starting at the C pointer returned by audio-stream-fragment. We use pointer->address to get the address of the pointer. A pointer refrences a byte of memory. We can reference the preceding or following byte by subtracting or adding 1 to the address. Since we are filling the array with 32-bit floats, and 32 bits is 4 bytes, we want to increment the address by 4 each time. Then we can set the value of the current location with pointer-f32-set!.

Then you just need to feed Allegro buffers of 1,024 samples at a time. The basic formula for a sine wave is A sin(2πft) where A is amplitude, f is frequency, and t is time.

(* amplitude (sin (* 2 +pi+ frequency time)))

Wire this up to a play button, and you’re ready to make some noise.

(define play-button (tk 'create-widget 'button 'text: "Play" 'command: (lambda ()
  (generate-tone (string->number (frequency-int 'get)) (string->number (duration-int 'get))))))
(tk/grid play-button 'row: 2 'column: 1 'padx: 20 'pady: 20)

Tk has been around a long time, and it shows. While it is stable and highly portable, even with recent improvements, it just looks a little dated. At least on Linux, none of the themes I tried really fit in. There were always differences that made the Tk GUI stick out like a sore thumb. If you’re building an internal tool where it doesn’t really matter how pretty it is, you can get Tk to work with a variety of Schemes in a variety of places.

You can check out the entire example on GitHub. This started as a personal learning project to explore the state of GUI programming in Lisp and has become a series of tutorials on building GUIs with various dialects of Lisp.

Source link