src

aiff.f90

module aiff
   use bytes, only: c, r
   use constants, only: audio, dp, eof, i2, i4, stderr
   use extended, only: decode, encode
   implicit none
   private

   public :: read_aiff, write_aiff

contains

   subroutine read_aiff(path, s)
      character(*), intent(in) :: path
      type(audio), intent(out) :: s

      integer :: i, fun, error
      character(1) :: byte
      character(4) :: ckID, formType, applicationSignature
      character(10) :: extended
      integer(i4) :: ckSize, offset, blockSize
      integer(i2) :: sampleSize

      open (newunit=fun, file=path, iostat=error, &
         action='read', status='old', access='stream')

      if (error .ne. 0) then
         write (stderr, "('Error: Cannot read AIFF file ''', A, '''.')") path
         stop
      end if

      do
         read (fun, iostat=error) ckID, ckSize
         if (error .eq. eof) exit

         ckSize = r(ckSize)

         select case (ckID)
         case ('FORM')
            read (fun) formType

         case ('COMM')
            read (fun) s%channels, s%points, sampleSize, extended

            s%channels = r(s%channels)
            s%points = r(s%points)
            sampleSize = r(sampleSize)
            s%rate = decode(extended)

            if (sampleSize .ne. 16_i2) then
               write (stderr, "('Error: Only 16 bits supported.')")
               stop
            end if

         case ('SSND')
            allocate(s%sound(s%channels, s%points))
            read (fun) offset, blockSize, s%sound

            offset = r(offset)
            blockSize = r(blockSize)
            s%sound = r(s%sound)

         case ('APPL')
            read (fun) applicationSignature

            if (applicationSignature .eq. 'FETZ') then
               read (fun) extended
               s%amplitude = decode(extended)
            else
               read (fun) (byte, i = 1, ckSize - 4)
            end if

         case ('ID3 ')
            allocate(character(ckSize) :: s%meta)
            read (fun) s%meta

         case default
            do i = 1, ckSize
               read (fun, iostat=error) byte

               if (error .ne. 0) then
                  write (stderr, "('Error: Corrupt AIFF file ''', A, '''.')") &
                     path
                  stop
               end if
            end do
         end select
      end do

      close (fun)
   end subroutine read_aiff

   subroutine write_aiff(path, s)
      character(*), intent(in) :: path
      type(audio), intent(in) :: s

      integer :: fun, error
      integer(i4), parameter :: commSize = 18_i4, applSize = 14_i4
      integer(i4), parameter :: offset = 0_i4, blockSize = 0_i4
      integer(i4) :: formSize, ssndSize
      integer(i2), parameter :: sampleSize = 16_i2
      integer(i2) :: blockAlign

      blockAlign = 2_i2 * s%channels

      ssndSize = 8_i4 + blockAlign * s%points
      formSize = 4_i4 + 8_i4 + commSize + 8_i4 + ssndSize

      if (s%amplitude .ne. 1.0_dp) formSize = formSize + 8_i4 + applSize

      if (allocated(s%meta)) formSize = formSize + 8_i4 + len(s%meta)

      if (path .eq. 'stdout' .or. path .eq. 'http') then
         if (path .eq. 'http') then
            write (*, "('Content-Type: audio/x-aiff')")
            write (*, "('Content-Length: ', I0, /)") formSize + 8
         end if

         write (*, '(*(A))', advance='no') &
            'FORM', c(r(formSize)), 'AIFF', &
            'COMM', c(r(commSize)), c(r(s%channels)), &
            c(r(s%points)), c(r(sampleSize)), encode(s%rate), &
            'SSND', c(r(ssndSize)), c(r(offset)), c(r(blockSize)), &
            c(r(s%sound))

         if (s%amplitude .ne. 1.0_dp) write (*, '(*(A))', advance='no') &
            'APPL', c(r(applSize)), 'FETZ',  encode(s%amplitude)

         if (allocated(s%meta)) write (*, '(*(A))', advance='no') &
            'ID3 ', c(r(len(s%meta, i4))), s%meta
      else
         open (newunit=fun, file=path, iostat=error, &
            action='write', status='replace', access='stream')

         if (error .ne. 0) then
            write (stderr, "('Error: Cannot write AIFF file ''', A, '''.')") &
               path
            stop
         end if

         write (fun) 'FORM', r(formSize), 'AIFF', &
            'COMM', r(commSize), r(s%channels), &
            r(s%points), r(sampleSize), encode(s%rate), &
            'SSND', r(ssndSize), r(offset), r(blockSize), &
            r(s%sound)

         if (s%amplitude .ne. 1.0_dp) write (fun) &
            'APPL', r(applSize), 'FETZ', encode(s%amplitude)

         if (allocated(s%meta)) write (fun) &
            'ID3 ', r(len(s%meta, i4)), s%meta

         close (fun)
      end if
   end subroutine write_aiff
end module aiff

aiff2riff.f90

subroutine aiff2riff
   use aiff, only: read_aiff
   use constants, only: audio
   use io, only: command_argument
   use riff, only: write_riff
   implicit none

   type(audio) :: s

   call read_aiff(command_argument(-2, '/dev/stdin'), s)
   call write_riff(command_argument(-1, '/dev/stdout'), s)
end subroutine aiff2riff

bytes.f90

module bytes
   use constants, only: i1, i2, i4
   implicit none
   private

   public :: c, r

   interface c
      module procedure chars_i2, chars_i4
   end interface c

   interface r
      module procedure reverse_i2, reverse_i4
   end interface r

contains

   elemental function chars_i2(i) result(o)
      integer(i2), intent(in) :: i
      character(2) :: o

      o = transfer(i, o)
   end function chars_i2

   elemental function chars_i4(i) result(o)
      integer(i4), intent(in) :: i
      character(4) :: o

      o = transfer(i, o)
   end function chars_i4

   elemental function reverse_i2(i) result(o)
      integer(i2), intent(in) :: i
      integer(i2) :: o
      integer(i1) :: j(2)

      j = transfer(i, j)
      j = j(2:1:-1)
      o = transfer(j, o)
   end function reverse_i2

   elemental function reverse_i4(i) result(o)
      integer(i4), intent(in) :: i
      integer(i4) :: o
      integer(i1) :: j(4)

      j = transfer(i, j)
      j = j(4:1:-1)
      o = transfer(j, o)
   end function reverse_i4
end module bytes

cgi.f90

! For standalone use on server, compile with FFLAGS='-static -O3'.
! Syntax highlighting in textarea inspired by Will Boyd's article:
! https://codersblock.com/blog/highlight-text-inside-a-textarea/

program tz_dot_cgi
   use constants, only: audio, dp
   use interpreter, only: play
   use io, only: environment_variable
   use riff, only: write_riff
   use tab, only: preprocess
   implicit none

   type(audio) :: music

   character(:), allocatable :: query
   integer, parameter :: limit = 1000000

   query = decode(environment_variable('QUERY_STRING'))

   if (query .eq. ' ') then
      write (*, '(A, /, *(:, /, A))') "Content-type: text/html", &
         "<!DOCTYPE html>", &
         "<html lang='en'>", &
         "  <head>", &
         "    <meta charset='utf-8'>", &
         "    <title>Tonbandfetzen</title>", &
         "    <link rel='icon' type='image/svg+xml' sizes='any'", &
         "      href='https://io.janberges.de/Tonbandfetzen/logo.svg'>", &
         "    <style>", &
         "      body {", &
         "        font: 12px sans-serif;", &
         "        color: #cccccc;", &
         "        background: #222222;", &
         "      }", &
         "      #color {", &
         "        position: absolute;", &
         "        color: #ffffff;", &
         "        background: #333333;", &
         "      }", &
         "      #mel {", &
         "        position: relative;", &
         "        color: transparent;", &
         "        background: transparent;", &
         "        caret-color: #ffffff;", &
         "      }", &
         "      #color, #mel, #play, #wav {", &
         "        display: block;", &
         "        box-sizing: border-box;", &
         "        width: 600px;", &
         "      }", &
         "      #color, #mel {", &
         "        height: 300px;", &
         "        resize: none;", &
         "        overflow-y: auto;", &
         "        padding: 5px;", &
         "        border: 0;", &
         "        margin: 0;", &
         "        font: bold 16px monospace;", &
         "        white-space: pre-wrap;", &
         "        word-wrap: break-word;", &
         "      }", &
         "      #play, #wav { margin-bottom: 5mm }", &
         "      .N { color: #bf8040 }", &
         "      .L { color: #afdf00 }", &
         "      .C { color: #da193b }", &
         "      a { color: inherit }", &
         "      a:hover { text-decoration: none }", &
         "    </style>", &
         "    <script>", &
         "      // @license &
         &magnet:?xt=urn:btih:90dc5c0be029de84e523b9b3922520e79e0e6f08&
         &&dn=cc0.txt CC0-1.0", &
         "      function enter() {", &
         "        document.getElementById('play').disabled = false", &
         "        var m = document.getElementById('mel').value", &
         "        m = m.replace(/&/g, '&AMP;')", &
         "        m = m.replace(/</g, '&LT;')", &
         "        m = m.replace(/[\d.:]+/g, '<SPAN CLASS=""N"">$&</SPAN>')", &
         "        m = m.replace(/[a-z#]+/g, '<SPAN CLASS=""L"">$&</SPAN>')", &
         "        m = m.replace(/\n$/g, '$&&nbsp;')", &
         "        m = m.replace(/\*[^*]*\*?/g, function(c) {", &
         "          c = c.replace(/<.+?>/g, '')", &
         "          return '<SPAN CLASS=""C"">' + c + '</SPAN>'", &
         "        })", &
         "        document.getElementById('color').innerHTML = m", &
         "      }", &
         "      function move() {", &
         "        document.getElementById('color').scrollTop =", &
         "          document.getElementById('mel').scrollTop", &
         "      }", &
         "      function play() {", &
         "        document.getElementById('play').disabled = true", &
         "        document.getElementById('wav').src = '?'", &
         "          + encodeURIComponent(", &
         "            document.getElementById('mel').value)", &
         "        document.getElementById('wav').load()", &
         "      }", &
         "      // @license-end", &
         "    </script>", &
         "  </head>", &
         "  <body onload='enter()'>", &
         "    <div id='color'></div>", &
         "    <textarea id='mel' spellcheck='false'", &
         "      oninput='enter()' onscroll='move()'>", &
         "$22050", &
         "*Harmonic series and cadence*", &
         "T pyth", &
         "X synth", &
         "M A2'8", &
         "W ,5 A2' A3' E4' A4' C#v5' E5' Gz5' A5'", &
         "E4|----0~~~|---2~~~~|-----0~~|----0~~~|", &
         "B3|---2~~~~|--3~~~~~|----0~~~|---2~~~~|", &
         "G3|--2~~~~~|-2~~~~~~|---1~~~~|--2~~~~~|", &
         "D3|-2~~~~~~|0~~~~~~~|--2~~~~~|-2~~~~~~|", &
         "A2|0~~~~~~~|--------|-2~~~~~~|0~~~~~~~|", &
         "E2|--------|--------|0~~~~~~~|--------|</textarea>", &
         "    <button id='play' onclick='play()'>Interpret</button>", &
         "    <audio id='wav' controls autoplay>Sorry</audio>", &
         "    Please have a look at the", &
         "    <a href='https://io.janberges.de/Tonbandfetzen/'>&
         &documentation</a> and the", &
         "    <a href='https://github.com/janberges/Tonbandfetzen'>&
         &source code</a>.", &
         "  </body>", &
         "</html>"
   else
      call play(preprocess(query), music, limit)

      if (music%points .eq. 0) call play("$22050 |1:6 E3' C3'", music)

      music%amplitude = 1.0_dp

      call write_riff('http', music)
   end if

contains

   function decode(code) result(url)
      character(:), allocatable :: url

      character(*), intent(in) :: code

      integer :: i, n

      url = code

      i = 1
      do
         n = index(url(i:), '%')
         if (n .eq. 0) exit
         i = n + i

         read (url(i:i + 1), '(Z2)') n
         url = url(:i - 2) // char(n) // url(i + 2:)
      end do
   end function decode
end program tz_dot_cgi

constants.f90

module constants
   use, intrinsic :: iso_fortran_env, only: &
      dp => real64, &
      eof => iostat_end, &
      eol => iostat_eor, &
      i1 => int8, &
      i2 => int16, &
      i4 => int32, &
      i8 => int64, &
      stderr => error_unit, &
      stdin => input_unit, &
      stdout => output_unit
   implicit none
   public

   integer(i2), parameter :: i2max = huge(1_i2) ! 2 ** 15 - 1

   real(dp), parameter :: pi = 4.0_dp * atan(1.0_dp)

   type audio
      integer(i2) :: channels
      integer(i4) :: points

      real(dp) :: rate
      real(dp) :: amplitude = 1.0_dp

      integer(i2), allocatable :: sound(:, :)

      character(:), allocatable :: meta
   end type audio
end module constants

extended.f90

module extended
   use constants, only: dp
   implicit none
   private

   public :: decode, encode

contains

   function decode(code) result(x)
      real(dp) :: x

      character(*), intent(in) :: code

      integer :: byte, bytes(10), bit, digit, sgn, power
      real(dp) :: mantissa

      do byte = 1, 10
         bytes(byte) = ichar(code(byte:byte))
      end do

      sgn = merge(-1, 1, btest(bytes(1), 7))
      mantissa = 0.0_dp
      power = -16383

      digit = 0
      do byte = 2, 1, -1
         do bit = 0, 5 + byte
            if (btest(bytes(byte), bit)) then
               power = power + 2 ** digit
            end if
            digit = digit + 1
         end do
      end do

      digit = 0
      do byte = 3, 10
         do bit = 7, 0, -1
            if (btest(bytes(byte), bit)) then
               mantissa = mantissa + 2.0_dp ** digit
            end if
            digit = digit - 1
         end do
      end do

      x = sgn * mantissa * 2.0_dp ** power
   end function decode

   function encode(x) result(code)
      character(10) :: code

      real(dp), intent(in) :: x

      integer :: byte, bytes(10), bit, power
      real(dp) :: mantissa

      power = int(log(abs(x)) / log(2.0_dp))
      mantissa = abs(x) / 2.0_dp ** power
      power = power + 16383

      bytes = 0

      if (x .lt. 0.0_dp) bytes(1) = ibset(bytes(1), 7)

      do byte = 2, 1, -1
         do bit = 0, 5 + byte
            if (modulo(power, 2) .eq. 1) then
               bytes(byte) = ibset(bytes(byte), bit)
            end if
            power = power / 2
         end do
      end do

      do byte = 3, 10
         do bit = 7, 0, -1
            if (mantissa .ge. 1.0_dp) then
               mantissa = mantissa - 1.0_dp
               bytes(byte) = ibset(bytes(byte), bit)
            end if
            mantissa = 2.0_dp * mantissa
         end do
      end do

      do byte = 1, 10
         code(byte:byte) = char(bytes(byte))
      end do
   end function encode
end module extended

fjs.f90

! The Functional Just System (FJS) has been invented by misotanni.
! For a complete description, see https://misotanni.github.io/fjs.
! Here, we only use the microtonal accidentals defined by the FJS.

module fjs
   use constants, only: dp
   implicit none
   private

   public :: accidentals, comma

contains

   function factorize(n) result(primes)
      integer, allocatable :: primes(:)
      integer, intent(in) :: n

      integer :: i, j

      allocate(primes(1:n))
      primes = 0

      i = n
      j = 2

      do while (i .gt. 1)
         if (modulo(i, j) .eq. 0) then
            primes(j) = primes(j) + 1
            i = i / j
         else
            j = j + 1
         end if
      end do
   end function factorize

   function accidentals(ratio)
      integer, allocatable :: accidentals(:)

      character(*), intent(in) :: ratio

      integer :: i, j, error
      integer :: numerator, denominator
      integer, allocatable :: primes(:), tmp(:)

      numerator = 1
      denominator = 1

      i = scan(ratio, ':/')
      if (i .eq. 0) i = len(ratio) + 1

      read (ratio(:i - 1), *, iostat=error) j
      if (error .eq. 0) numerator = j

      read (ratio(i + 1:), *, iostat=error) j
      if (error .eq. 0) denominator = j

      allocate(primes(1:max(numerator, denominator)))
      primes = 0

      tmp = factorize(numerator)
      primes(:size(tmp)) = primes(:size(tmp)) + tmp

      tmp = factorize(denominator)
      primes(:size(tmp)) = primes(:size(tmp)) - tmp

      allocate(accidentals(sum(abs(primes))))

      j = 1
      do i = 1, size(primes)
         accidentals(j:) = sign(i, primes(i))
         j = j + abs(primes(i))
      end do
   end function accidentals

   elemental function red(d)
      real(dp) :: red
      real(dp), intent(in) :: d

      red = d / 2.0_dp ** floor(log(d) / log(2.0_dp))
   end function red

   elemental function reb(d)
      real(dp) :: reb
      real(dp), intent(in) :: d

      reb = red(sqrt(2.0_dp) * red(d)) / sqrt(2.0_dp)
   end function reb

   elemental function cents(d)
      real(dp) :: cents
      real(dp), intent(in) :: d

      cents = 1200.0_dp * log(d) / log(2.0_dp)
   end function cents

   elemental function error(d)
      real(dp) :: error
      real(dp), intent(in) :: d

      error = abs(cents(reb(d)))
   end function error

   elemental function master(d) result(f)
      integer :: f
      real(dp), intent(in) :: d

      real(dp) :: tol

      tol = error(65.0_dp / 63.0_dp)

      f = 0
      do while (error(d / 3.0_dp ** f) .ge. tol)
         f = -f
         if (f .ge. 0) f = f + 1
      end do
   end function master

   elemental function comma(p)
      real(dp) :: comma
      integer, intent(in) :: p

      real(dp), parameter :: Pyth_comma = 3.0_dp ** 12 / 2.0_dp ** 19
      integer :: d

      d = abs(p)

      if (d .eq. 3) then
         comma = Pyth_comma
      else
         comma = reb(d / 3.0_dp ** master(real(d, dp)))
      end if

      if (p .lt. 0) comma = 1.0_dp / comma
   end function comma
end module fjs

guitar.f90

subroutine guitar
   use constants, only: stderr
   use io, only: command_argument, slurp
   use tab, only: preprocess
   implicit none

   integer :: fun, error

   character(:), allocatable :: path, notes

   notes = preprocess(slurp(command_argument(1, '/dev/stdin')))

   path = command_argument(2, '/dev/stdout')

   if (path .eq. 'stdout') then
      write (*, '(A)', advance='no') notes
   else
      open (newunit=fun, file=path, iostat=error, &
         action='write', status='replace', access='stream')

      if (error .ne. 0) then
         write (stderr, "('Error: Cannot write file ''', A, '''.')") path
         stop
      end if

      write (fun) notes
      close (fun)
   end if
end subroutine guitar

harmonics.f90

subroutine harmonics
   use constants, only: dp
   use io, only: command_argument
   use samples, only: sample
   use spectra, only: fourier
   implicit none

   integer :: n
   integer, parameter :: nmax = 99

   real(dp) :: wave(2 * nmax), amplitude, phase
   complex(dp) :: spectrum(nmax)

   call sample(wave, 'wave', command_argument(1, 'circular'))

   call fourier(wave, spectrum)

   write (*, "(/ 'f(t) = sum r[n] cos(n omega t - phi[n])' /)")
   write (*, '(A2, 2A15)') 'n', 'r[n]', 'phi[n]'

   do n = 1, size(spectrum)
      amplitude = 2.0_dp * abs(spectrum(n))

      if (amplitude .lt. 1e-10_dp) cycle

      phase = atan2(aimag(spectrum(n)), real(spectrum(n)))

      write (*, '(I2, 2F15.10)') n, amplitude, phase
   end do
end subroutine harmonics

id3.f90

module id3
   use constants, only: dp, eof, i1, stderr
   use io, only: slurp
   use paths, only: extension
   implicit none
   private

   public :: read_id3, write_id3

contains

   subroutine read_id3(id3)
      character(*), intent(in) :: id3

      integer :: i, n, flags, tagSize, frameSize
      integer(i1) :: version, revision
      character(3) :: tagID
      character(4) :: frameID
      character(:), allocatable :: feature, text

      tagID = id3(1:3)

      if (tagID .eq. 'TAG') then
         write (stderr, "('Warning: ID3v1 not supported.')") feature
         return
      end if

      version = ichar(id3(4:4), i1)
      revision = ichar(id3(5:5), i1)

      if (version .le. 2) then
         write (stderr, "('Warning: ', A, 'v2.', I0, ' not supported.')") &
            tagID, version
         return
      end if

      write (stderr, "('Metadata format: ', A, 'v2.', I0, '.', I0)") &
         tagID, version, revision

      flags = ichar(id3(6:6))

      do i = 7, 4, -1
         if (btest(flags, i)) then
            select case (i)
            case (7)
               feature = 'unsynchronisation'
            case (6)
               feature = 'extended header'
            case (5)
               feature = 'experimental tag'
            case (4)
               feature = 'footer'
            end select

            write (stderr, "('Warning: ID3 ', A, ' not supported.')") feature
            return
         end if
      end do

      i = 10

      tagSize = decode_size(id3(7:10))

      do while (i .lt. 10 + tagSize)
         if (ichar(id3(i + 1:i + 1)) .eq. 0) exit

         frameID = id3(i + 1:i + 4)

         select case (frameID)
         case ('APIC')
            feature = 'picture'
         case ('COMM')
            feature = 'comment'
         case ('PRIV')
            feature = 'private'
         case ('TALB')
            feature = 'album'
         case ('TCOM')
            feature = 'composer'
         case ('TCON')
            feature = 'genre'
         case ('TCOP')
            feature = 'copyright'
         case ('TENC')
            feature = 'encoded by'
         case ('TIT2')
            feature = 'title'
         case ('TLEN')
            feature = 'duration/ms'
         case ('TOPE')
            feature = 'original artist'
         case ('TPE1')
            feature = 'artist'
         case ('TPE2')
            feature = 'album artist'
         case ('TPOS')
            feature = 'disc number'
         case ('TRCK')
            feature = 'track number'
         case ('TYER')
            feature = 'year'
         case ('WAAA':'WXXX')
            feature = 'website'
         case default
            feature = 'unknown'
         end select

         frameSize = decode_size(id3(i + 5:i + 8), synchsafe=version .eq. 4_i1)

         flags = ichar(id3(i + 9:i + 9))

         if (btest(flags, 6)) write (stderr, "(A, ' tag-bound')") frameID
         if (btest(flags, 5)) write (stderr, "(A, ' file-bound')") frameID
         if (btest(flags, 4)) write (stderr, "(A, ' read-only')") frameID

         flags = ichar(id3(i + 10:i + 10))

         if (btest(flags, 6)) write (stderr, "(A, ' grouped')") frameID
         if (btest(flags, 3)) write (stderr, "(A, ' compressed')") frameID
         if (btest(flags, 2)) write (stderr, "(A, ' encrypted')") frameID
         if (btest(flags, 1)) write (stderr, "(A, ' unsyrchronised')") frameID
         if (btest(flags, 0)) write (stderr, "(A, ' states length')") frameID

         i = i + 10

         if (frameID(1:1) .eq. 'T') then
            text = id3(i + 2:i + frameSize)

            select case (ichar(id3(i + 1:i + 1)))
            case (0) ! ISO-8859-1
               text = encode_utf8(decode_iso8859_1(text))
            case (1, 2) ! UTF-16, UTF-16BE
               text = encode_utf8(decode_utf16(text))
            case (3) ! UTF-8
               continue
            end select

            do
               n = index(text, char(0))

               if (n .eq. 0) exit

               if (n .eq. len(text)) then
                  text = text(:n - 1)
               else
                  text = text(:n - 1) // '/' // text(n + 1:)
               end if
            end do
         else
            text = repeat(' ', 64)
            write (text, "(I0, ' bytes')") frameSize
            text = trim(text)
         end if

         if (feature .ne. 'unknown') then
            write (stderr, "(A, ' (', A, '): ', A)") frameID, feature, text
         else
            write (stderr, "(A, ': ', A)") frameID, text
         end if

         i = i + frameSize
      end do
   end subroutine read_id3

   function write_id3(path) result(id3)
      character(:), allocatable :: id3

      character(*), intent(in) :: path

      character(4) :: frameID
      character(256) :: buffer
      character(:), allocatable :: text, mime

      integer(i1), parameter :: version = 4_i1
      integer(i1), parameter :: revision = 0_i1
      integer(i1), parameter :: flags = 0_i1
      integer(i1), parameter :: encoding = 3_i1

      integer :: fun, error
      logical :: exists

      inquire (file=path, exist=exists)

      id3 = ''

      if (exists) then
         open (newunit=fun, file=path, action='read', status='old', &
            iostat=error)

         if (error .ne. 0) then
            write (stderr, "('Error: Cannot read ID3 file ''', A, '''.')") path
            stop
         end if

         do
            read (fun, '(A4, 1X, A)', iostat=error) frameID, buffer
            text = trim(buffer)

            if (error .eq. eof) exit

            if (frameID .eq. 'APIC') then
               select case(extension(text))
               case ('jpeg', 'jpg', 'JPEG', 'JPG')
                  mime = 'image/jpeg'
               case ('png', 'PNG')
                  mime = 'image/png'
               case ('svg', 'SVG')
                  mime = 'image/svg+xml'
               case ('tiff', 'tif', 'TIFF', 'TIF')
                  mime = 'image/tiff'
               case ('gif', 'GIF')
                  mime = 'image/gif'
               case ('bmp', 'BMP')
                  mime = 'image/bmp'
               end select

               text = mime // char(0) // char(3) // 'cover' // char(0) &
                  // slurp(text)
            else if (frameID(1:1) .ne. 'T') then
               write (stderr, "('Warning: ', A, ' not supported.')") frameID
               continue
            end if

            id3 = id3 // frameID // encode_size(1 + len(text), &
               synchsafe=version .eq. 4_i1) // char(flags) // char(flags) &
               // char(encoding) // text
         end do

         close (fun)
      end if

      if (len(id3) .gt. 0) id3 = 'ID3' // char(version) // char(revision) &
         // char(flags) // encode_size(len(id3)) // id3
   end function write_id3

   function decode_size(code, synchsafe) result(s)
      integer :: s

      character(*), intent(in) :: code
      logical, intent(in), optional :: synchsafe

      integer :: byte, base

      base = 128

      if (present(synchsafe)) then
         if (.not. synchsafe) base = 256
      end if

      s = 0
      do byte = 1, 4
         s = s + ichar(code(byte:byte)) * base ** (4 - byte)
      end do
   end function decode_size

   function encode_size(s, synchsafe) result(code)
      character(4) :: code

      integer, intent(in) :: s
      logical, intent(in), optional :: synchsafe

      integer :: byte, base

      base = 128

      if (present(synchsafe)) then
         if (.not. synchsafe) base = 256
      end if

      do byte = 1, 4
         code(byte:byte) = char(modulo(s / base ** (4 - byte), base))
      end do
   end function encode_size

   function decode_iso8859_1(code) result(unicode)
      integer, allocatable :: unicode(:)

      character(*), intent(in) :: code

      integer :: byte

      allocate(unicode(len(code)))

      do byte = 1, len(code)
         unicode(byte) = ichar(code(byte:byte))
      end do
   end function decode_iso8859_1

   function decode_utf16(code) result(unicode)
      integer, allocatable :: unicode(:)

      character(*), intent(in) :: code

      integer :: c, s, v
      logical :: be

      allocate(unicode(len(code) / 2))

      be = .true.

      v = 1
      do c = 1, len(code), 2
         if (be) then
            s = ichar(code(c:c)) * 256 + ichar(code(c + 1:c + 1))
         else
            s = ichar(code(c + 1:c + 1)) * 256 + ichar(code(c:c))
         end if

         if (s .eq. 65279) then ! FEFF (BOM)
            continue
         else if (s .eq. 65534) then ! FFFE (wrong BOM)
            be = .not. be
         else if (55296 .le. s .and. s .lt. 56320) then ! high surrogate
            unicode(v) = 1024 * (s - 55296)
         else if (56320 .le. s .and. s .lt. 57344) then ! low surrogate
            unicode(v) = 65536 + s - 56320 + unicode(v)
            v = v + 1
         else ! basic multilingual plane
            unicode(v) = s
            v = v + 1
         end if
      end do

      unicode = unicode(:v - 1)
   end function decode_utf16

   function encode_utf8(unicode) result(code)
      character(:), allocatable :: code

      integer, intent(in) :: unicode(:)

      integer :: c, i, j, n, v

      code = ''

      do v = lbound(unicode, 1), ubound(unicode, 1)
         if (unicode(v) .lt. 128) then
            code = code // char(unicode(v))
         else
            do n = 1, 5
               if (unicode(v) .lt. 64 * 32 ** n) then
                  do i = n, 0, -1
                     c = 128 + modulo(unicode(v) / 64 ** i, 64)
                     if (i .eq. n) then
                        do j = 1, n
                           c = c + 128 / 2 ** j
                        end do
                     end if
                     code = code // char(c)
                  end do
                  exit
               end if
            end do
         end if
      end do
   end function encode_utf8
end module id3

inspect.f90

subroutine inspect
   use aiff, only: read_aiff
   use constants, only: audio, stderr
   use id3, only: read_id3
   use io, only: command_argument, slurp
   use paths, only: extension
   use riff, only: read_riff
   implicit none

   character(:), allocatable :: path
   type(audio) :: s

   path = command_argument(1, '/dev/stdin')

   select case (extension(path))
   case ('aiff', 'aif', 'AIFF', 'AIF')
      call read_aiff(path, s)

   case ('wave', 'wav', 'WAVE', 'WAV', '')
      call read_riff(path, s)

   case ('mp3', 'MP3')
      call read_id3(slurp(path))
      stop

   case default
      write (stderr, "('Error: Unknown filename extension.')")
      stop
   end select

   if (allocated(s%meta)) call read_id3(s%meta)

   write (*, "('Number of channels: ', I0)") s%channels
   write (*, "('Number of sample points: ', I0)") s%points
   write (*, "('Sample rate: ', F0.1, ' Hz')") s%rate
   write (*, "('Duration: ', F0.1, ' s')") s%points / s%rate
   write (*, "('Amplitude: ', F0.1)") s%amplitude
end subroutine inspect

interpreter.f90

module interpreter
   use constants, only: audio, dp, i2, i2max, stderr
   use fjs, only: accidentals, comma
   use io, only: command_argument
   use lcg, only: minstd
   use rationals, only: rational
   use riff, only: read_riff
   use samples, only: sample
   use search, only: focus, get, known, lexical, next, &
      numeral, remember, reset, revert, set, special
   use synthesis, only: karplus_strong
   implicit none
   private

   public :: play

contains

   subroutine play(notes, tones, limit)
      character(*), intent(in) :: notes
      type(audio), intent(out) :: tones
      integer, intent(in), optional :: limit

      character(*), parameter :: initial = '!"%&+-=?@ABCDEFGNQSUVWXYZ[]`~'

      character(:), allocatable :: symbol, word ! special/lexical string

      real(dp), allocatable :: wave(:), rise(:), fall(:) ! sound samples
      real(dp), allocatable :: rho(:), tau(:), phi(:) ! sound segment
      real(dp), allocatable :: mel(:, :) ! melody
      real(dp), allocatable :: work(:, :) ! temporary data

      logical :: todo(3) ! samples yet to be initialized?
      logical :: over ! end of input reached?

      real(dp) :: x ! exact time
      real(dp) :: b ! beat duration

      integer :: t ! rounded time
      integer :: c ! continuance
      integer :: p ! processed time (plus command count)
      integer :: d ! note duration

      integer :: tmin, tmax, cmax ! extreme times

      real(dp) :: A4 ! concert pitch

      integer :: steps ! notes per octave

      real(dp) :: f ! frequency f(t)
      real(dp) :: f0 ! reference frequency
      real(dp) :: fi ! initial frequency
      real(dp) :: fd ! f(t + d) / f(t)
      real(dp) :: fb ! f(t + b) / f(t)
      real(dp) :: f1 ! f(t + 1) / f(t)

      real(dp) :: a ! amplitude a(t) = sqrt(L^2 + R^2)
      real(dp) :: a0 ! reference amplitude
      real(dp) :: ai ! initial amplitude
      real(dp) :: ad ! a(t + d) / a(t)
      real(dp) :: ab ! a(t + b) / a(t)
      real(dp) :: a1 ! a(t + 1) / a(t)

      real(dp) :: r ! amplitudes ratio r(t) = R:L
      real(dp) :: r0 ! reference ratio
      real(dp) :: ri ! initial ratio
      real(dp) :: rd ! r(t + d) / r(t)
      real(dp) :: rb ! r(t + b) / r(t)
      real(dp) :: r1 ! r(t + 1) / r(t)

      logical :: loudness ! boost low frequencies?
      real(dp) :: boost ! amplitude scaling factor

      logical :: synth, tuned ! employ Karplus and Strong's synthesizer?
      real(dp) :: blend, decay ! blend and inverse decay-stretch factors

      real(dp) :: phase ! turn = 1

      integer :: i, j, k ! arbitrary integers/indices
      logical :: l ! arbitrary logical

      real(dp) :: s ! equivalent of a second

      ! time marks
      real(dp) :: marks(0:99)
      logical :: mark_set(0:99)
      real(dp) :: x1, x2, dx
      integer :: t1, t2, dt

      real(dp) :: random, factor

      ! tuning
      character(:), allocatable :: tuning

      real(dp), parameter :: equal_fifth = 2.0_dp ** (7.0_dp / 12.0_dp)
      real(dp), parameter :: just_fifth = 1.5_dp

      integer :: keynote, tone, newtone

      integer, allocatable :: primes(:)

      integer :: keycount(-25:23)

      tuning = 'equal'
      tone = 0
      keynote = -3 ! C

      keycount = 0

      tones%rate = 44100.0_dp
      tones%channels = -1_i2

      todo = .true.

      call focus(notes)

      do
         select case (next(special, length=1))
         case ('$')
            tones%rate = n()

         case ('~')
            todo(1) = .false.
         case ('S')
            todo(2) = .false.
         case ('Z')
            todo(3) = .false.
         case ('N')
            todo(2:3) = .false.

         case ('*')
            if (next('*', length=1, barrier='*') .eq. 'none') exit

         case ("'", 'none')
            exit
         end select
      end do

      s = tones%rate

      if (todo(1)) call load(wave, 'wave', 'circular', nint(1.0_dp * s))
      if (todo(2)) call load(rise, 'fade', 'circular', nint(0.1_dp * s))
      if (todo(3)) call load(fall, 'fade', 'circular', nint(0.1_dp * s))

      b = 0.5_dp * s

      x = 0.0_dp

      t = 0
      c = 0
      p = 0

      tmin = t
      tmax = t
      cmax = c

      call reset
      mark_set = .false.

      do
         symbol = next(special, length=1)

         tmin = min(tmin, t)
         tmax = max(tmax, t)

         if (done()) then
            cmax = max(cmax, c)
            c = 0
         end if

         select case (symbol)
         case ('~', 'S', 'Z', 'N')
            if (next(lexical) .ne. '#') then
               p = p + nint(n(1.0_dp) * s)
            end if

         case ('O')
            tones%channels = int(n(), i2)

         case ('%', '(', ')', '[', ']', '{', '}')
            if (tones%channels .eq. -1_i2) tones%channels = 2_i2

         case ("'")
            x = x + n(1.0_dp) * b
            d = nint(x) - t
            c = c + d
            t = t + d
            p = p + d

         case default
            call routine_cases
            if (over) exit
         end select

         p = p + 1

         if (present(limit)) then
            if (p .gt. limit) exit
         end if
      end do

      allocate(rho(cmax))
      allocate(tau(cmax))
      allocate(phi(cmax))

      tones%points = tmax - tmin

      if (tones%channels .eq. -1_i2) tones%channels = 1_i2

      if (present(limit)) then
         if (p .gt. limit .or. tones%points .gt. limit) tones%points = 0
      end if

      allocate(mel(tones%channels, tones%points))

      if (tones%points .eq. 0) return

      mel = 0.0_dp

      b = 0.5_dp * s
      A4 = 440.0_dp / s
      steps = 12

      f0 = A4
      f = f0
      fi = f0
      fd = 1.0_dp
      fb = 1.0_dp

      a0 = 1.0_dp
      a = a0
      ai = a0
      ad = 1.0_dp
      ab = 1.0_dp

      r0 = 1.0_dp
      r = r0
      ri = r0
      rd = 1.0_dp
      rb = 1.0_dp

      loudness = .false.

      synth = .false.
      tuned = .true.
      blend = 1.0_dp
      decay = 1.0_dp

      phase = 0.0_dp

      x = 0.0_dp

      t = -tmin
      c = 0

      call reset
      mark_set = .false.

      do
         symbol = next(special, length=1)

         if (done()) then
            f = fi
            a = ai
            r = ri

            rho = rho * tau

            i = min(size(rise), c)

            rho(:i) = rho(:i) * rise(:i - 1)

            i = max(c - size(fall) + 1, 1)

            rho(c:i:-1) = rho(c:i:-1) * fall(:c - i)

            i = t - c + 1

            select case (tones%channels)
            case (1_i2)
               mel(1, i:t) = mel(1, i:t) + rho(:c)

            case (2_i2)
               mel(1, i:t) = mel(1, i:t) + rho(:c) * cos(phi(:c))
               mel(2, i:t) = mel(2, i:t) + rho(:c) * sin(phi(:c))
            end select

            c = 0
         end if

         select case (symbol)
         case ('~', 'S', 'Z', 'N')
            word = next(lexical)

            if (word .eq. '#') then
               i = int(n(1.0_dp))
            else
               i = nint(n(1.0_dp) * s)
            end if

            select case (symbol)
            case ('~')
               call load(wave, 'wave', word, i)
            case ('S')
               call load(rise, 'fade', word, i)
            case ('Z')
               call load(fall, 'fade', word, i)
            case ('N')
               call load(rise, 'fade', word, i)
               fall = rise
            end select

         case ('X')
            word = next(lexical)

            select case (word)
            case ('loudness')
               loudness = n(1.0_dp) .ne. 0.0_dp

            case ('synth')
               synth = n(1.0_dp) .ne. 0.0_dp

            case ('blend')
               blend = n(1.0_dp)

            case ('decay')
               decay = n(1.0_dp)

            case ('tuned')
               tuned = n(1.0_dp) .ne. 0.0_dp

            case ('status')
               write (stderr, "(*(A10, ':', F16.9, 1X, A, :, /))") &
                  'Time', t / s, 's', &
                  'Frequency', f * s, 'Hz', &
                  'Amplitude', a, 'arb. units', &
                  'Balance', 10.0_dp * log10(r), 'dB', &
                  'Phase', phase, '(mod 1)'

            case ('report')
               write (stderr, "('Note counts:')")

               do i = lbound(keycount, 1), ubound(keycount, 1)
                  if (keycount(i) .gt. 0) then
                     j = modulo(i + 4, 7) + 1

                     write (stderr, "(A)", advance='no') 'FCGDAEB'(j:j)

                     j = (i + 4 - (j - 1)) / 7

                     if (j < 0) write (stderr, "(A)", advance='no') &
                        repeat('b', -j)

                     if (j > 0) write (stderr, "(A)", advance='no') &
                        repeat('#', j)

                     write (stderr, "(': ', I0)") keycount(i)
                  end if
               end do

               keycount = 0

            case ('detune')
               call minstd(random)
               random = 1.0_dp - 2.0_dp * random
               random = 2.0_dp ** (random * n() / steps)
               A4 = A4 * random
               f0 = f0 * random
               fi = fi * random
               f = f * random

            case ('delete', 'reverse', 'flanger', 'vibrato')
               i = int(n())
               j = int(n())

               if (mark_set(i) .and. mark_set(j)) then
                  t1 = nint(marks(i))
                  t2 = nint(marks(j))

                  select case (word)
                  case ('delete')
                     mel(:, t1 + 1:t2) = 0.0_dp

                  case ('reverse')
                     mel(:, t1 + 1:t2) = mel(:, t2:t1 + 1:-1)

                  case ('flanger', 'vibrato')
                     dx = n() * s

                     factor = n() * size(wave) / (t2 - t1 - 1)

                     allocate(work(tones%channels, t2 - t1))

                     do i = 0, t2 - t1 - 1
                        work(:, 1 + i) = mel(:, t1 + 1 + i + nint(dx * &
                           wave(modulo(nint(i * factor), size(wave)))))
                     end do

                     select case (word)
                     case ('flanger')
                        mel(:, t1 + 1:t2) = mel(:, t1 + 1:t2) + work
                     case ('vibrato')
                        mel(:, t1 + 1:t2) = work
                     end select

                     deallocate(work)
                  end select
               end if

            case default
               write (stderr, "('Warning: Unknown action ''', A, '''.')") word
            end select

         case ('T')
            tuning = next(lexical)

            select case (tuning)
            case ('equal', 'pyth', 'just', 'close')
               continue
            case default
               write (stderr, "('Warning: Unknown tuning ''', A, '''.')") tuning
               write (stderr, "('The tuning ''equal'' is used instead.')")
               write (stderr, "('See ''man tz mel'' for list of tunings.')")
               tuning = 'equal'
            end select

         case ('H')
            steps = nint(n())

         case ('C', 'D', 'E', 'F', 'G', 'A', 'B', 'U', 'V')
            fi = f ! remember current frequency

            f = A4

            if (index('UV', symbol) .ne. 0) then
               newtone = tone + sgn('VU') * int(n())
               i = keynote - 5 + modulo(newtone * 7 - keynote + 5, 12)
            else
               i = index('FCGDAEB', symbol) - 5
            end if

            word = next(lexical, '')

            do j = 1, len(word)
               select case (word(j:j))
               case ('b')
                  i = i - 7
               case ('#')
                  i = i + 7
               case ('x')
                  i = i + 14
               case ('v') ! syntonic comma down
                  f = f * comma(5)
               case ('u') ! syntonic comma up
                  f = f * comma(-5)
               case ('z') ! septimal comma down
                  f = f * comma(7)
               case ('s') ! septimal comma up
                  f = f * comma(-7)
               case ('j') ! 11-comma down
                  f = f * comma(-11)
               case ('i') ! 11-comma up
                  f = f * comma(11)
               case ('d') ! ditonic comma down
                  f = f * comma(-3)
               case ('p') ! Pythagorean comma up
                  f = f * comma(3)
            end select
            end do

            if (lbound(keycount, 1) .le. i .and. &
                ubound(keycount, 1) .ge. i) then
               keycount(i) = keycount(i) + 1
            end if

            select case (tuning)
            case ('equal')
               f = f * equal_fifth ** i

            case ('pyth')
               f = f * just_fifth ** i

            case ('just')
               f = f * just_fifth ** i
               j = i + modulo(1 - keynote, 4)
               j = (j - modulo(j, 4)) / 4
               f = f * comma(5) ** j

            case ('close')
               f = f * just_fifth ** i
               j = i + modulo(5 - keynote, 11)
               j = (j - modulo(j, 11)) / 11
               f = f * comma(5) ** j
            end select

            ! fold back to first octave:
            j = 4 * i + 5
            j = (j - modulo(j, 7)) / 7
            f = f / 2.0_dp ** j

            ! position on twelve-tone scale:
            j = i * 7 - 12 * j

            if (index('UV', symbol) .ne. 0) then
               j = (newtone - j) / 12
            else
               word = next(numeral, 'none')

               tone = j

               if (word .eq. 'none') then
                  j = 4 + nint(log(fi / f) / log(2.0_dp))

                  keynote = i
               else
                  j = nint(rational(word))
               end if

               tone = tone + 12 * j
            end if

            f = f * 2.0_dp ** (j - 4)
            fi = f

            word = next(numeral, 'none')

            if (word .ne. 'none') then
               primes = accidentals(word)
               do j = 1, size(primes)
                  f = f * comma(primes(j))
               end do
            end if

            if (index('UV', symbol) .eq. 0) f0 = f

         case ('@')
            A4 = n(s / size(wave)) / s
            f0 = A4
            fi = f0
            f = fi

         case ('&')
            a0 = n()
            ai = a0
            a = ai

         case ('%')
            r0 = n()
            ri = r0
            r = ri

         case ('R')
            f0 = f
            fi = f0
            a0 = a
            ai = a0
            r0 = r
            ri = r0

         case ('Q')
            fi = n() * f0
            f = fi

         case ('_', '^')
            fb = 2.0_dp ** (sgn('_^') * n() / steps)
         case ('\', '/')
            fd = 2.0_dp ** (sgn('\/') * n() / steps)
         case ('-', '+')
            fi = 2.0_dp ** (sgn('-+') * n() / steps) * f0
            f = fi

         case (',', ';')
            ab = 10.0_dp ** (sgn(',;') * n() * 0.1_dp)
         case ('>', '<')
            ad = 10.0_dp ** (sgn('><') * n() * 0.1_dp)
         case ('?', '!')
            ai = 10.0_dp ** (sgn('?!') * n() * 0.1_dp) * a0
            a = ai

         case ('{', '}')
            rb = 10.0_dp ** (sgn('{}') * n() * 0.1_dp)
         case ('(', ')')
            rd = 10.0_dp ** (sgn('()') * n() * 0.1_dp)
         case ('[', ']')
            ri = 10.0_dp ** (sgn('[]') * n() * 0.1_dp) * r0
            r = ri

         case ('P')
            phase = n()

         case ("'")
            x = x + n(1.0_dp) * b
            d = nint(x) - t

            f1 = fd ** (1.0_dp / d) * fb ** (1.0_dp / b)
            fd = 1.0_dp
            a1 = ad ** (1.0_dp / d) * ab ** (1.0_dp / b)
            ad = 1.0_dp
            r1 = rd ** (1.0_dp / d) * rb ** (1.0_dp / b)
            rd = 1.0_dp

            if (loudness) then
               boost = A4 / f
            else
               boost = 1.0_dp
            end if

            do i = c + 1, c + d
               phase = phase - floor(phase)

               if (synth) then
                  call karplus_strong(rho, i, 1.0_dp / f, blend, decay, tuned)
               else
                  rho(i) = wave(floor(size(wave) * phase))
               end if

               tau(i) = a * boost
               phi(i) = atan(r)

               phase = phase + f

               f = f * f1
               a = a * a1
               r = r * r1
            end do

            c = c + d
            t = t + d

         case default
            call routine_cases
            if (over) exit
         end select
      end do

      tones%amplitude = maxval(abs(mel))

      if (tones%amplitude .ne. 0.0_dp) mel = mel / tones%amplitude

      if (tones%channels .eq. 2_i2) then
         tones%amplitude = sqrt(2.0_dp) * tones%amplitude
      end if

      tones%sound = nint(i2max * mel, i2)

   contains

      function done()
         logical :: done

         done = symbol .eq. 'none'
         done = done .or. scan(symbol, initial) .gt. 0
         done = done .and. c .gt. 0
      end function done

      function n(def)
         real(dp) :: n

         real(dp), intent(in), optional :: def

         if (present(def)) then
            n = rational(next(numeral, '-1'))
            if (n .eq. -1.0_dp) n = def
         else
            n = rational(next(numeral))
         end if
      end function n

      function sgn(minusplus)
         integer :: sgn

         character(2), intent(in) :: minusplus

         sgn = 2 * index(minusplus, symbol) - 3
      end function sgn

      subroutine routine_cases
         over = .false.

         select case (symbol)
         case ('|')
            b = n() * s

         case ('"', '`')
            x = x + sgn('`"') * n(1.0_dp) * b
            t = nint(x)

         case ('M')
            i = int(n(0.0_dp))
            marks(i) = x
            mark_set(i) = .true.

         case ('W')
            i = int(n(0.0_dp))
            if (mark_set(i)) then
               x = marks(i)
               t = nint(x)
            end if

         case ('Y')
            i = int(n())
            j = int(n())

            if (mark_set(i) .and. mark_set(j)) then
               x1 = marks(i)
               x2 = marks(j)
               dx = x2 - x1

               if (allocated(mel)) then
                  t1 = nint(x1)
                  t2 = nint(x2)
                  dt = t2 - t1
               end if

               do i = 1, int(n(1.0_dp))
                  x = x + dx
                  t = nint(x)

                  if (allocated(mel)) mel(:, t - dt + 1:t) &
                     = mel(:, t - dt + 1:t) + mel(:, t1 + 1:t2)
               end do
            end if

         case ('I')
            call remember(int(n(0.0_dp)))

         case ('J')
            i = int(n(0.0_dp))

            if (known(i)) then
               j = int(n(1.0_dp))

               if (j .eq. 0) j = i2max

               call get(k)

               if (k .lt. j) then
                  call set(k + 1)
                  call revert(i)
               else
                  call set(0)
               end if
            end if

         case ('K', 'L')
            call get(i)
            i = i + 1
            call set(i)

            do
               j = int(n(-1.0_dp))
               l = i .eq. j
               if (l .or. j .eq. -1) exit
            end do

            if (symbol .eq. 'K' .eqv. l) then
               do
                  if (next(special, length=1) .ne. '*') return
                  if (next('*', length=1, barrier='*') .eq. 'none') exit
               end do

               over = .true.
            end if

         case ('*')
            if (next('*', length=1, barrier='*') .eq. 'none') over = .true.

         case ('none')
            over = .true.
         end select
      end subroutine routine_cases
   end subroutine play

   subroutine load(x, what, how, i)
      real(dp), intent(out), allocatable :: x(:)
      character(*), intent(in) :: what, how
      integer, intent(in) :: i
      type(audio) :: s

      if (how .eq. '#') then
         if (i .gt. command_argument_count() - 3) then
            write (stderr, "('Error: File ', I0, ' missing.')") i
            stop
         end if

         call read_riff(command_argument(i, '/dev/stdin'), s)

         allocate(x(0:s%points - 1))

         x = s%amplitude / i2max * s%sound(0, :)
      else
         allocate(x(0:i - 1))

         call sample(x, what, how)
      end if
   end subroutine load
end module interpreter

intervals.f90

module intervals
   use constants, only: dp
   implicit none
   private

   public :: interval

contains

   subroutine interval(x, a, b, n)
      real(dp), intent(out) :: x(:)
      real(dp), intent(in) :: a, b
      integer, intent(in), optional :: n
      !      n:      0      1      2      3
      ! binary:     00     01     10     11
      ! yields:  (a,b)  (a,b]  [a,b)  [a,b]

      integer :: i, j, k

      i = size(x)
      j = 1

      if (present(n)) then
         if (btest(n, 1)) j = j - 1
         if (btest(n, 0)) i = i - 1
      end if

      if (i + j .eq. 0) then
         i = 1
         j = 1
      end if

      do k = 1, size(x)
         x(k) = i * a + j * b
         i = i - 1
         j = j + 1
      end do

      x = x / (i + j)
   end subroutine interval
end module intervals

io.f90

module io
   use constants, only: eof, eol, stderr
   implicit none
   private

   public :: slurp, command_argument, environment_variable

contains

   function slurp(path) result(content)
      character(:), allocatable :: content

      character(*), intent(in) :: path

      integer :: fun, i, error
      logical :: f

      character, parameter :: lf = new_line('A')

      f = path .ne. 'stdin'

      if (f) then
         open (newunit=fun, file=path, iostat=error, &
            action='read', status='old', access='stream')

         if (error .ne. 0) then
            write (stderr, "('Error: Cannot read file ''', A, '''.')") path
            stop
         end if
      end if

      allocate(character(1048576) :: content)

      do i = 1, len(content)
         if (f) then
            read (fun, iostat=error) content(i:i)
         else
            read (*, '(A1)', iostat=error, advance='no') content(i:i)
            if (error .eq. eol) content(i:i) = lf
         end if
         if (error .eq. eof) then
            content = content(1:i - 1)
            exit
         end if
      end do

      if (f) close (fun)
   end function slurp

   function command_argument(num, def) result(arg)
      character(:), allocatable :: arg

      integer, intent(in) :: num
      character(*), intent(in) :: def

      integer :: i, n, length

      i = num
      n = command_argument_count()

      if (-n .lt. i .and. i .lt. 0) i = i + n

      i = i + 1

      if (i .lt. 1 .or. i .gt. n) then
         arg = def
      else
         call get_command_argument(i, length=length)

         allocate(character(length) :: arg)

         call get_command_argument(i, value=arg)

         if (arg .eq. '-') arg = def
      end if
   end function command_argument

   function environment_variable(name) result(var)
      character(:), allocatable :: var

      character(*), intent(in) :: name

      integer :: length

      call get_environment_variable(name, length=length)

      allocate(character(length) :: var)

      if (len(var) .gt. 0) then
         call get_environment_variable(name, value=var)
      end if
   end function environment_variable
end module io

lcg.f90

! https://en.wikipedia.org/wiki/MINSTD

module lcg
   use constants, only: dp, i8
   implicit none
   private

   public :: minstd

   integer(i8), parameter :: a = 48271_i8, m = 2147483647_i8
   integer(i8), save :: i = 1_i8
   real(dp), parameter :: s = 1.0_dp / m

contains

   subroutine minstd(r)
      real(dp), intent(out) :: r

      i = modulo(i * a, m)
      r = s * i
   end subroutine minstd
end module lcg

mel.f90

subroutine mel
   use constants, only: audio
   use interpreter, only: play
   use io, only: command_argument, slurp
   use riff, only: write_riff
   implicit none

   type(audio) :: music

   call play(slurp(command_argument(-2, '/dev/stdin')), music)
   call write_riff(command_argument(-1, '/dev/stdout'), music)
end subroutine mel

mono.f90

subroutine mono
   use constants, only: audio, i2
   use io, only: command_argument
   use riff, only: read_riff, write_riff
   implicit none

   integer(i2) :: c
   type(audio) :: m, s

   call read_riff(command_argument(1, '/dev/stdin'), s)

   m%channels = 1_i2
   m%points = s%points
   m%rate = s%rate
   m%amplitude = s%amplitude

   do c = 1, s%channels
      m%sound = s%sound(c:c, :)

      call write_riff(command_argument(c + 1, '/dev/null'), m)
   end do
end subroutine mono

paths.f90

module paths
   implicit none
   private

   public :: extension, stem

contains

   function extension(path)
      character(:), allocatable :: extension

      character(*), intent(in) :: path

      integer :: dot, slash

      dot = index(path, '.', back=.true.)
      slash = scan(path, '/\:', back=.true.)

      if (dot .gt. slash) then
         extension = path(dot + 1:)
      else
         extension = ''
      end if
   end function extension

   function stem(path)
      character(:), allocatable :: stem

      character(*), intent(in) :: path

      integer :: dot, slash

      dot = index(path, '.', back=.true.)
      slash = scan(path, '/\:', back=.true.)

      if (dot .gt. slash) then
         stem = path(:dot - 1)
      else
         stem = path
      end if
   end function stem
end module paths

play.f90

subroutine playz
   use aiff, only: read_aiff
   use constants, only: audio
   use interpreter, only: play
   use io, only: command_argument, slurp
   use paths, only: extension
   use riff, only: write_riff
   use tab, only: preprocess
   implicit none

   character(:), allocatable :: infile, outfile
   type(audio) :: s

   infile = command_argument(1, '/dev/stdin')
   outfile = command_argument(2, '/dev/shm/tmp.wav')

   select case (extension(infile))
   case ('wave', 'wav', 'mp3', 'WAVE', 'WAV', 'MP3')
      call execute_command_line('xdg-open ' // infile)
      return

   case ('aiff', 'aif', 'AIFF', 'AIF')
      call read_aiff(infile, s)

   case default
      call play(preprocess(slurp(infile)), s)
   end select

   call write_riff(outfile, s)
   call execute_command_line('xdg-open ' // outfile)
end subroutine playz

rationals.f90

module rationals
   use constants, only: dp
   implicit none
   private

   public :: rational

contains

   function rational(ratio)
      real(dp) :: rational

      character(*), intent(in) :: ratio

      integer :: i, error
      real(dp) :: numerator, denominator

      i = scan(ratio, ':/')

      if (i .eq. 0) then
         read (ratio, *, iostat=error) rational
         if (error .ne. 0) rational = 0.0_dp
      else
         read (ratio(:i - 1), *, iostat=error) numerator
         if (error .ne. 0) numerator = 0.0_dp

         read (ratio(i + 1:), *, iostat=error) denominator
         if (error .ne. 0) denominator = 1.0_dp

         rational = numerator / denominator
      end if
   end function rational
end module rationals

repeat.f90

subroutine repeatz
   use constants, only: audio, dp
   use io, only: command_argument
   use rationals, only: rational
   use riff, only: read_riff, write_riff
   implicit none

   integer :: i
   real(dp) :: factor
   type(audio) :: s1, s

   factor = rational(command_argument(1, '2'))

   call read_riff(command_argument(2, '/dev/stdin'), s1)

   s%channels = s1%channels
   s%points = nint(abs(factor) * s1%points)
   s%rate = s1%rate
   s%amplitude = s1%amplitude

   allocate(s%sound(s%channels, s%points))

   if (factor .gt. 0.0_dp) then
      do i = 1, s%points
         s%sound(:, i) = s1%sound(:, 1 + modulo(i - 1, s1%points))
      end do
   else
      do i = 1, s%points
         s%sound(:, s%points + 1 - i) &
            = s1%sound(:, 1 + modulo(s1%points - i, s1%points))
      end do
   end if

   call write_riff(command_argument(3, '/dev/stdout'), s)
end subroutine repeatz

riff.f90

module riff
   use bytes, only: c
   use constants, only: audio, dp, eof, i2, i4, stderr
   use extended, only: decode, encode
   implicit none
   private

   public :: read_riff, write_riff

contains

   subroutine read_riff(path, s)
      character(*), intent(in) :: path
      type(audio), intent(out) :: s

      integer :: i, fun, error
      character(1) :: byte
      character(4) :: ckID, formType, applicationSignature
      character(10) :: extended
      integer(i4) :: ckSize, sampleRate, byteRate
      integer(i2) :: sampleSize, formatTag, blockAlign

      open (newunit=fun, file=path, iostat=error, &
         action='read', status='old', access='stream')

      if (error .ne. 0) then
         write (stderr, "('Error: Cannot read RIFF file ''', A, '''.')") path
         stop
      end if

      do
         read (fun, iostat=error) ckID, ckSize
         if (error .eq. eof) exit

         select case (ckID)
         case ('RIFF')
            read (fun) formType

         case ('fmt ')
            read (fun) formatTag, s%channels, sampleRate, byteRate
            read (fun) blockAlign, sampleSize

            s%rate = real(sampleRate, dp)

            if (sampleSize .ne. 16_i2) then
               write (stderr, "('Error: Only 16 bits supported.')")
               stop
            end if

         case ('data')
            s%points = ckSize / (2 * s%channels)
            allocate(s%sound(s%channels, s%points))
            read (fun) s%sound

         case ('APPL')
            read (fun) applicationSignature

            if (applicationSignature .eq. 'FETZ') then
               read (fun) extended
               s%amplitude = decode(extended)
            else
               read (fun) (byte, i = 1, ckSize - 4)
            end if

         case ('ID3 ', 'id3 ')
            allocate(character(ckSize) :: s%meta)
            read (fun) s%meta

         case default
            do i = 1, ckSize
               read (fun, iostat=error) byte

               if (error .ne. 0) then
                  write (stderr, "('Error: Corrupt RIFF file ''', A, '''.')") &
                     path
                  stop
               end if
            end do
         end select
      end do

      close (fun)
   end subroutine read_riff

   subroutine write_riff(path, s)
      character(*), intent(in) :: path
      type(audio), intent(in) :: s

      integer :: fun, error
      integer(i4), parameter :: fmtSize = 16_i4, applSize = 14_i4
      integer(i4) :: riffSize, dataSize, sampleRate, byteRate
      integer(i2), parameter :: sampleSize = 16_i2, formatTag = 1_i2
      integer(i2) :: blockAlign

      blockAlign = 2_i2 * s%channels
      sampleRate = nint(s%rate, i4)
      byteRate = blockAlign * sampleRate

      dataSize = blockAlign * s%points
      riffSize = 4_i4 + 8_i4 + fmtSize + 8_i4 + dataSize

      if (s%amplitude .ne. 1.0_dp) riffSize = riffSize + 8_i4 + applSize

      if (allocated(s%meta)) riffSize = riffSize + 8_i4 + len(s%meta)

      if (path .eq. 'stdout' .or. path .eq. 'http') then
         if (path .eq. 'http') then
            write (*, "('Content-Type: audio/x-wav')")
            write (*, "('Content-Length: ', I0, /)") riffSize + 8
         end if

         write (*, '(*(A))', advance='no') &
            'RIFF', c(riffSize), 'WAVE', &
            'fmt ', c(fmtSize), c(formatTag), c(s%channels), &
            c(sampleRate), c(byteRate), c(blockAlign), c(sampleSize), &
            'data', c(dataSize), c(s%sound)

         if (s%amplitude .ne. 1.0_dp) write (*, '(*(A))', advance='no') &
            'APPL', c(applSize), 'FETZ', encode(s%amplitude)

         if (allocated(s%meta)) write (*, '(*(A))', advance='no') &
            'ID3 ', c(len(s%meta, i4)), s%meta
      else
         open (newunit=fun, file=path, iostat=error, &
            action='write', status='replace', access='stream')

         if (error .ne. 0) then
            write (stderr, "('Error: Cannot write RIFF file ''', A, '''.')") &
               path
            stop
         end if

         write (fun) 'RIFF', riffSize, 'WAVE', &
            'fmt ', fmtSize, formatTag, s%channels, &
            sampleRate, byteRate, blockAlign, sampleSize, &
            'data', dataSize, s%sound

         if (s%amplitude .ne. 1.0_dp) write (fun) &
            'APPL', applSize, 'FETZ', encode(s%amplitude)

         if (allocated(s%meta)) write (fun) &
            'ID3 ', len(s%meta, i4), s%meta

         close (fun)
      end if
   end subroutine write_riff
end module riff

riff2aiff.f90

subroutine riff2aiff
   use aiff, only: write_aiff
   use constants, only: audio
   use io, only: command_argument
   use riff, only: read_riff
   implicit none

   type(audio) :: s

   call read_riff(command_argument(-2, '/dev/stdin'), s)
   call write_aiff(command_argument(-1, '/dev/stdout'), s)
end subroutine riff2aiff

samples.f90

module samples
   use constants, only: dp, pi, stderr
   use intervals, only: interval
   use lcg, only: minstd
   implicit none
   private

   public :: sample

contains

   subroutine sample(x, what, how)
      real(dp), intent(out) :: x(:)
      character(*), intent(in) :: what, how

      integer :: i

      select case (what)
      case ('wave')
         select case (how)
         case default ! harmonic
            call warn
            call interval(x, 0.0_dp, 2.0_dp * pi, 1)
            x = sin(x)

         case ('power')
            call interval(x, 0.0_dp, 2.0_dp * pi, 1)
            x = sin(x) ** 3

         case ('major')
            call interval(x, 0.0_dp, 2.0_dp * pi, 1)
            x = sin(x) ** 5

         case ('constant')
            call interval(x, 0.0_dp, 2.0_dp * pi, 1)
            x = sign(1.0_dp, sin(x))

         case ('linear')
            call interval(x, 0.0_dp, 2.0_dp * pi, 1)
            x = 2.0_dp / pi * asin(sin(x))

         case ('quadratic')
            call interval(x, -2.0_dp, 2.0_dp, 1)
            x = sign(2.0_dp * abs(x) - x ** 2, x)

         case ('circular')
            call interval(x, -2.0_dp, 2.0_dp, 1)
            x = sign(sqrt(2.0_dp * abs(x) - x ** 2), x)

         case ('cubic')
            call interval(x, -1.0_dp, 1.0_dp, 1)
            x = 1.5_dp * sqrt(3.0_dp) * (x ** 3 - x)

         case ('water')
            call interval(x, 0.0_dp, 1.0_dp, 1)
            x = 1.5_dp * sqrt(3.0_dp) * (x ** 3 - x) + 0.5_dp

         case ('random')
            do i = 1, size(x)
               call minstd(x(i))
            end do
            x = 2.0_dp * x - 1.0_dp
         end select

      case ('fade')
         select case (how)
         case default ! harmonic
            call warn
            call interval(x, 0.0_dp, 0.5_dp * pi, 0)
            x = sin(x)

         case ('smooth')
            call interval(x, 0.0_dp, 0.5_dp * pi, 0)
            x = sin(x) ** 2

         case ('power')
            call interval(x, 0.0_dp, 0.5_dp * pi, 0)
            x = sin(x) ** 3

         case ('major')
            call interval(x, 0.0_dp, 0.5_dp * pi, 0)
            x = sin(x) ** 5

         case ('linear')
            call interval(x, 0.0_dp, 1.0_dp, 0)

         case ('quadratic')
            call interval(x, -1.0_dp, 0.0_dp, 0)
            x = 1.0_dp - x ** 2

         case ('circular')
            call interval(x, -1.0_dp, 0.0_dp, 0)
            x = sqrt(1.0_dp - x ** 2)

         case ('cubic')
            call interval(x, 0.0_dp, 1.0_dp, 0)
            x = 3.0_dp * x ** 2 - 2.0_dp * x ** 2
         end select
      end select

   contains

      subroutine warn
         if (how .ne. 'harmonic') then
            write (stderr, "('Warning: Unknown sample ''', A, '''.')") how
            write (stderr, "('The sample ''harmonic'' is used instead.')")
            write (stderr, "('See ''man tz mel'' for list of samples.')")
         end if
      end subroutine warn
   end subroutine sample
end module samples

search.f90

module search
   use constants, only: i2
   implicit none
   private

   public :: focus, reset, next, remember, revert, known, set, get, &
      numeral, lexical, special

   character(:), allocatable :: text
   integer(i2), allocatable :: info(:)

   integer, save :: last, marks(0:99)

   character(*), parameter :: &
      numeral = '.0123456789:', &
      lexical = 'abcdefghijklmnopqrstuvwxyz#', &
      special = '!"$%&''()*+,-/;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`{|}~'

   character(*), parameter :: canonical = numeral // lexical // special

contains

   subroutine focus(it)
      character(*), intent(in) :: it

      text = it

      if (allocated(info)) deallocate(info)
      allocate(info(len(text)))

      call reset
   end subroutine focus

   subroutine reset
      last = 0
      marks = -1
      info = 0
   end subroutine reset

   function next(set, def, length, barrier)
      character(:), allocatable :: next

      character(*), intent(in) :: set
      character(*), intent(in), optional :: def
      integer, intent(in), optional :: length
      character(*), intent(in), optional :: barrier

      integer :: first, break

      character(:), allocatable :: blocking

      if (present(barrier)) then
         blocking = barrier
      else if (present(def)) then
         blocking = canonical
      else
         blocking = special
      end if

      first = scan(text(last + 1:), set)
      break = scan(text(last + 1:), blocking)

      if (first .eq. 0 .or. break .ne. 0 .and. break .lt. first) then
         if (present(def)) then
            next = def
         else
            next = 'none'
         end if
         return
      end if

      first = first + last

      if (present(length)) then
         last = first + length - 1
      else
         last = verify(text(first + 1:), set)

         if (last .eq. 0) then
            last = len(text)
         else
            last = last + first - 1
         end if
      end if

      next = text(first:last)
   end function next

   subroutine remember(mark)
      integer, intent(in) :: mark

      marks(mark) = last
   end subroutine remember

   subroutine revert(mark)
      integer, intent(in) :: mark

      if (known(mark)) last = marks(mark)
   end subroutine revert

   function known(mark)
      logical :: known
      integer, intent(in) :: mark

      known = marks(mark) .ne. -1
   end function known

   subroutine set(i)
      integer, intent(in) :: i

      info(last) = int(i, i2)
   end subroutine set

   subroutine get(i)
      integer, intent(out) :: i

      i = info(last)
   end subroutine get
end module search

spectra.f90

module spectra
   use constants, only: dp, pi
   implicit none
   private

   public :: fourier

contains

   subroutine fourier(wave, spectrum)
      real(dp), intent(in) :: wave(:)
      complex(dp), intent(out) :: spectrum(:)

      integer :: n, m
      real(dp) :: omega, phi
      complex(dp) :: transform(size(spectrum), size(wave))

      omega = 2.0_dp * pi / size(wave)

      do m = 1, size(wave)
         do n = 1, size(spectrum)
            phi = n * m * omega
            transform(n, m) = cmplx(cos(phi), sin(phi), dp)
         end do
      end do

      spectrum = matmul(transform, wave) / size(wave)
   end subroutine fourier
end module spectra

stack.f90

subroutine stack
   use constants, only: audio, dp, i2, i2max
   use io, only: command_argument
   use riff, only: read_riff, write_riff
   implicit none

   integer :: i, n, t
   integer(i2) :: c
   real(dp), allocatable :: sound(:, :)
   type(audio), allocatable :: p(:)
   type(audio) :: s

   s%channels = 1_i2
   s%points = 0
   s%rate = 1.0_dp
   s%amplitude = 0.0_dp

   n = command_argument_count() - 2

   allocate(p(n))

   do i = 1, n
      call read_riff(command_argument(i, '/dev/stdin'), p(i))

      s%channels = max(s%channels, p(i)%channels)
      s%points = max(s%points, p(i)%points)
      s%rate = max(s%rate, p(i)%rate)
   end do

   allocate(s%sound(s%channels, s%points))
   allocate(sound(s%channels, s%points))

   sound = 0.0_dp

   do i = 1, n
      do t = 1, s%points
         do c = 1, s%channels
            sound(c, t) = sound(c, t) + p(i)%amplitude * p(i)%sound( &
               1_i2 + modulo(c - 1_i2, p(i)%channels), &
               1_i2 + modulo(t - 1_i2, p(i)%points))
         end do
      end do
   end do

   sound = sound / i2max

   if (s%points .gt. 0) then
      s%amplitude = maxval(abs(sound))
      s%sound = nint(i2max / s%amplitude * sound, i2)
   end if

   call write_riff(command_argument(-1, '/dev/stdout'), s)
end subroutine stack

stick.f90

subroutine stick
   use constants, only: audio, dp, i2
   use io, only: command_argument
   use riff, only: read_riff, write_riff
   implicit none

   integer :: i, n, offset
   integer(i2) :: c
   type(audio), allocatable :: p(:)
   type(audio) :: s

   s%channels = 1_i2
   s%points = 0
   s%rate = 1.0_dp
   s%amplitude = 0.0_dp

   n = command_argument_count() - 2

   allocate(p(n))

   do i = 1, n
      call read_riff(command_argument(i, '/dev/stdin'), p(i))

      s%points = s%points + p(i)%points

      s%channels = max(s%channels, p(i)%channels)
      s%amplitude = max(s%amplitude, p(i)%amplitude)
      s%rate = max(s%rate, p(i)%rate)
   end do

   allocate(s%sound(s%channels, s%points))

   offset = 0

   do i = 1, n
      if (p(i)%amplitude .ne. s%amplitude) then
         p(i)%sound = int(p(i)%sound * p(i)%amplitude / s%amplitude, i2)
      end if

      do c = 1, s%channels
         s%sound(c, offset + 1:offset + p(i)%points) &
            = p(i)%sound(1_i2 + modulo(c - 1_i2, p(i)%channels), :)
      end do

      offset = offset + p(i)%points
   end do

   call write_riff(command_argument(-1, '/dev/stdout'), s)
end subroutine stick

stretch.f90

subroutine stretch
   use constants, only: audio, dp, i2
   use io, only: command_argument
   use rationals, only: rational
   use riff, only: read_riff, write_riff
   implicit none

   integer :: t, t0
   real(dp) :: t1, dt, scaling, factor
   type(audio) :: s0, s

   factor = rational(command_argument(1, '-1'))

   call read_riff(command_argument(2, '/dev/stdin'), s0)

   s%channels = s0%channels
   s%points = nint(abs(factor) * s0%points)
   s%rate = s0%rate
   s%amplitude = s0%amplitude

   if (s%points .eq. s0%points) then
      s%sound = s0%sound
   else
      allocate(s%sound(s0%channels, s%points))

      scaling = real(s0%points - 1, dp) / real(max(s%points, 2) - 1, dp)

      do t = 0, s%points - 1
         t1 = 1.0_dp + scaling * t
         t0 = floor(t1)
         dt = t1 - t0
         s%sound(:, 1 + t) = nint(s0%sound(:, t0) * (1.0_dp - dt) &
            + s0%sound(:, t0 + 1) * dt, i2)
      end do
   end if

   if (factor .lt. 0.0_dp) s%sound = s%sound(:, s%points:1:-1)

   call write_riff(command_argument(3, '/dev/stdout'), s)
end subroutine stretch

synthesis.f90

! From Kevin Karplus and Alex Strong, Digital Synthesis of Plucked-String and
! Drum Timbre, Comput. Music J. 7, 43 (1983), https://doi.org/10.2307/3680062.
! Implementation inspired by Vincent Magnin's Fortran synthesizer "ForSynth",
! see https://vmagnin.github.io/forsynth.

module synthesis
   use constants, only: dp
   use lcg, only: minstd
   implicit none
   private

   public :: karplus_strong

contains

   subroutine karplus_strong(y, t, period, blend, decay, tuned)
      real(dp), intent(inout) :: y(:)
      integer, intent(in) :: t
      real(dp), intent(in) :: period, blend, decay
      logical, intent(in) :: tuned

      integer :: p
      real(dp) :: r, v, w

      r = max(period, 1.0_dp)

      if (tuned) then
         p = nint(r)
         v = 0.5_dp + r - p
      else
         p = floor(r) ! signal frequency is 1 / (p + 1/2)
         v = 1.0_dp
      end if

      w = 1.0_dp - v

      call minstd(r)

      if (t .lt. p + 2) then
         y(t) = 2.0_dp * r - 1.0_dp
      else if (r .ge. decay) then
         y(t) = y(t - p)
      else
         y(t) = 0.5_dp * (v * y(t - p - 1) + y(t - p) + w * y(t - p + 1))
      end if

      call minstd(r)
      if (r .ge. blend) y(t) = -y(t)
   end subroutine karplus_strong
end module synthesis

tab.f90

module tab
   implicit none
   private

   public :: preprocess, strip, matches, sub

   integer :: beats

contains

   function preprocess(tablature) result(notes)
      character(:), allocatable :: notes

      character(*), intent(in) :: tablature

      integer :: lower, upper, from, till
      logical :: first

      character :: c
      character, parameter :: lf = achar(10), cr = achar(13)
      character(2), parameter :: rn = cr // lf
      character(:), allocatable :: nl, line, bar, bars

      notes = ''

      first = .true.

      lower = 1
      do while (lower .le. len(tablature))
         upper = scan(tablature(lower:), rn)

         if (upper .eq. 0) then
            upper = len(tablature)

            nl = ''
         else
            upper = lower + upper - 2

            nl = tablature(upper + 1:upper + 1)

            if (upper + 2 .le. len(tablature)) then
               c = tablature(upper + 2:upper + 2)

               if (scan(c, rn) .eq. 1 .and. c .ne. nl) nl = nl // c
            end if
         end if

         line = trim(tablature(lower:upper))

         lower = upper + len(nl) + 1

         if (matches(line, '|') .gt. 1) then
            if (first) then
               bars = 'M0'
               first = .false.
            else
               bars = 'W0'
            end if

            from = 1
            do while (from .le. len(line))
               till = scan(line(from:), '|')

               if (till .eq. 0) then
                  till = len(line)
               else
                  till = from + till - 2
               end if

               bar = line(from:till)

               from = till + 2

               if (scan(bar, '-~') .ne. 0) then
                  bar = sub(bar, 'X', replace='-')
                  bar = sub(bar, 'SZNT', replace='~')

                  bar = sub(bar, '-~', invert=.true., &
                     keep=.true., replace='~')

                  bar = sub(bar, '0.123456789:', before='-~', &
                     insert='U', keep=.true.)

                  beats = matches(bar, '-~')

                  bar = sub(bar, '-', insert='"', ratio=.true.)
                  bar = sub(bar, '~', insert="'", ratio=.true.)
               end if

               bars = bars // strip(bar)
            end do

            notes = notes // bars // nl
         else
            if (len(strip(line)) .eq. 0) first = .true.

            notes = notes // line // nl
         end if
      end do
   end function preprocess

   function strip(string)
      character(:), allocatable :: strip
      character(*), intent(in) :: string

      character(*), parameter :: whitespace = char(9) // ' '
      integer :: lower, upper

      lower = verify(string, whitespace)

      if (lower .eq. 0) then
         strip = ''
         return
      end if

      upper = verify(string, whitespace, back=.true.)

      strip = string(lower:upper)
   end function strip

   function matches(string, set)
      integer :: matches
      character(*), intent(in) :: string, set

      integer :: i

      matches = 0

      do i = 1, len_trim(string)
         if (index(set, string(i:i)) .ne. 0) matches = matches + 1
      end do
   end function matches

   function sub(string, set, invert, before, insert, ratio, keep, replace)
      character(:), allocatable :: sub
      character(*), intent(in) :: string, set
      character(*), intent(in), optional :: before, insert, replace
      logical, intent(in), optional :: invert, ratio, keep

      integer :: i, j
      logical :: inverted
      character(1024) :: tmp

      if (present(invert)) then
         inverted = invert
      else
         inverted = .false.
      end if

      sub = ''

      i = 1
      do
         if (i .gt. len(string)) exit

         if (inverted) then
            j = verify(string(i:), set)
         else
            j = scan(string(i:), set)
         end if

         if (j .eq. 0) then
            j = len(string) + 1
         else
            j = i + j - 1
         end if

         sub = sub // string(i:j - 1)

         if (j .gt. len(string)) exit

         if (inverted) then
            i = scan(string(j:), set)
         else
            i = verify(string(j:), set)
         end if

         if (i .eq. 0) then
            i = len(string) + 1
         else
            i = j + i - 1
         end if

         if (present(before)) then
            if (j .gt. 1) then
               if (index(before, string(j - 1:j - 1)) .eq. 0) then
                  sub = sub // string(j:i - 1)
                  cycle
               end if
            end if
         end if

         if (present(insert)) sub = sub // insert

         if (present(ratio)) then
            if (ratio) then
               write (tmp, "(I0, ':', I0)") i - j, beats
               sub = sub // trim(tmp)
            end if
         end if

         if (present(keep)) then
            if (keep) sub = sub // string(j:i - 1)
         end if

         if (present(replace)) then
            sub = sub // repeat(replace, i - j)
         end if
      end do
   end function sub
end module tab

tag.f90

subroutine tag
   use constants, only: audio, dp
   use id3, only: write_id3
   use io, only: command_argument
   use paths, only: stem
   use riff, only: read_riff, write_riff
   implicit none

   integer :: i
   character(:), allocatable :: infile, datafile, outfile
   type(audio) :: s

   infile = command_argument(1, '/dev/stdin')

   datafile = command_argument(2, '-')

   if (datafile .eq. '-') datafile = stem(infile) // '.id3'

   outfile = command_argument(3, '-')

   if (outfile .eq. '-') then
      i = index(infile, 'stdin', back=.true.)

      if (i .ne. 0) then
         outfile = infile(:i - 1) // 'stdout' // infile(i + 6:)
      else
         outfile = infile
      end if
   end if

   call read_riff(infile, s)

   s%meta = write_id3(datafile)

   if (len(s%meta) .eq. 0) deallocate(s%meta)

   s%amplitude = 1.0_dp

   call write_riff(outfile, s)
end subroutine tag

trim.f90

subroutine trimz
   use constants, only: audio, dp, i2max
   use io, only: command_argument
   use rationals, only: rational
   use riff, only: read_riff, write_riff
   implicit none

   integer :: a, i, z
   real(dp) :: threshold
   type(audio) :: s0, s

   threshold = rational(command_argument(1, '0')) * i2max

   call read_riff(command_argument(2, '/dev/stdin'), s0)

   do i = 1, s0%points
      a = i
      if (any(s0%sound(:, a) .gt. threshold)) exit
   end do

   do i = s0%points, a - 1, -1
      z = i
      if (any(s0%sound(:, z) .gt. threshold)) exit
   end do

   s%channels = s0%channels
   s%points = z - a + 1
   s%rate = s0%rate
   s%amplitude = s0%amplitude
   s%sound = s0%sound(:, a:z)

   call write_riff(command_argument(3, '/dev/stdout'), s)
end subroutine trimz

tz.f90

program tz
   use io, only: command_argument
   implicit none

   external :: aiff2riff, guitar, harmonics, inspect, mel, mono, playz, &
      repeatz, riff2aiff, stack, stick, stretch, tag, trimz

   character(:), allocatable :: command

   command = command_argument(0, 'help')

   select case (command)
   case ('mel'); call mel
   case ('guitar'); call guitar
   case ('stick'); call stick
   case ('stack'); call stack
   case ('stretch'); call stretch
   case ('repeat'); call repeatz
   case ('trim'); call trimz
   case ('mono'); call mono
   case ('harmonics'); call harmonics
   case ('inspect'); call inspect
   case ('riff2aiff'); call riff2aiff
   case ('aiff2riff'); call aiff2riff
   case ('tag'); call tag
   case ('play'); call playz
   case ('help'); call help
   case default
      write (*, "('Unknown command ""', A, '""', /)") command
      call help
   end select

contains

   subroutine help
      write (*, "(A, /, *(:, /, '    tz ', A))") &
         'Tonbandfetzen usage:', &
         'mel [[[wavefile ...] infile] outfile]', &
         'guitar [infile [outfile]]', &
         'stick [[infile ...] outfile]', &
         'stack [[infile ...] outfile]', &
         'stretch [factor [infile [outfile]]]', &
         'repeat [count [infile [outfile]]]', &
         'trim [threshold [infile [outfile]]]', &
         'mono [infile [outfile ...]]', &
         'harmonics [label]', &
         'inspect [file]', &
         'riff2aiff [[infile] outfile]', &
         'aiff2riff [[infile] outfile]', &
         'tag [infile [datafile [outfile]]]', &
         'play [infile [outfile]]'
   end subroutine help
end program tz