Algorithmische Komposition mit Common Lisp

;;; 
;;; piano-phase-defs-amp.lisp
;;;
;;; Code to generate the complete version of Piano Phase by Steve
;;; Reich
;;;
;;; **********************************************************************
;;; Copyright (c) 2025 Orm Finnendahl <orm.finnendahl@selma.hfmdk-frankfurt.de>
;;;
;;; Revision history: See git repository.
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the Gnu Public License, version 2 or
;;; later. See https://www.gnu.org/licenses/gpl-2.0.html for the text
;;; of this agreement.
;;; 
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; **********************************************************************

(in-package :clamps)

;;; Utils:

(defun get-duration (dur &optional (tempo '(1/4 60)))
  "get the duration in seconds for /dur/ at a given tempo.

@Example
 (get-duration 1/16 '(1/4 72)) ; => 5/24 (0.20833333, 125/6%)
"
  (* dur (/ 60 (apply #'* tempo))))

(defun rest-calc-shift (old new)
  "Return a list of new shift values by adding the values of /new/ to the
values of /old/. Replace the value nil in /new/ with 0 before adding."
  (mapcar (lambda (oldval newval) (+ oldval (or newval 0))) old new))

(defun get-amp-values (ampchange num-notes)
  "Return a list with start-amp and delta-amp with given /ampchange/
being :cresc, decresc or nil and /num-notes/."
  (case ampchange
    (:cresc (list -26 (/ 20.0 (1- num-notes))))
    (:decresc (list -6 (/ -20.0 (1- num-notes))))
    (otherwise (list -6 0.0))))

(defun expand-pattern (pattern)
   (if (numberp (first pattern)) (list pattern pattern) pattern))

(defun section-duration (num-repeats pattern dtime)
  "Return the duration of a section with given params."
  (* num-repeats (length pattern) dtime))

(defun part-duration (part pattern dtime)
  "Return the duration of /part/ with given /pattern/ and /dtime/."
  (loop for (num-repeats shift cresc) in part summing (section-duration num-repeats pattern dtime)))

(defun get-real-score (score)
  "Replace the (min max) list of num-repeats in all sections of /score/
with a randomly calculated number in the range [min..max]."
  (loop
    for part in score
    collect (loop
              for section in part
              collect (destructuring-bind ((min max) &rest rest) section
                        (cons (between min (1+ max)) rest)))))

;;; Score:

(defparameter *piano-phase-score*
  '((((4 8) (0 nil))                             ;;;  1  Beginn 1. Teil
     ((12 18) (0 0) (nil :cresc)) ((4 16) (0 1)) ;;;  2
     ((16 24) (0 0)) ((4 16) (0 1))              ;;;  3
     ((16 24) (0 0)) ((4 16) (0 1))              ;;;  4
     ((16 24) (0 0)) ((4 16) (0 1))              ;;;  5
     ((16 24) (0 0)) ((4 16) (0 1))              ;;;  6
     ((16 24) (0 0)) ((4 16) (0 1))              ;;;  7
     ((16 24) (0 0)) ((4 16) (0 1))              ;;;  8
     ((12 24) (0 0)) ((4 16) (0 1))              ;;;  9
     ((12 24) (0 0)) ((4 16) (0 1))              ;;; 10
     ((12 24) (0 0)) ((4 16) (0 1))              ;;; 11
     ((12 24) (0 0)) ((4 16) (0 1))              ;;; 12
     ((12 24) (0 0)) ((4 16) (0 1))              ;;; 13
     ((4 8) (0 0) (nil :decresc))                ;;; 14
     ((4 8) (0 nil)))                            ;;; 15
    (((6 8) (0 nil))                             ;;; 16  Beginn 2. Teil
     ((16 32) (0 0) (nil :cresc)) ((6 18) (0 1)) ;;; 17
     ((16 32) (0 0)) ((6 18) (0 1))              ;;; 18
     ((16 32) (0 0)) ((6 18) (0 1))              ;;; 19
     ((16 32) (0 0)) ((6 18) (0 1))              ;;; 20
     ((16 32) (0 0)) ((6 18) (0 1))              ;;; 21
     ((16 32) (0 0)) ((6 18) (0 1))              ;;; 22
     ((16 32) (0 0)) ((6 18) (0 1))              ;;; 23
     ((16 32) (0 0)) ((6 18) (0 1))              ;;; 24
     ((8 24) (0 0) (:decresc nil))               ;;; 25
     ((8 16) (nil 0)))                           ;;; 26
    (((2 2) (nil 0)))                            ;;; 26a Beginn 3. Teil
    (((8 24) (nil 0))                            ;;; 27  Beginn 4. Teil
     ((24 48) (0 0)) ((16 32) (0 1))             ;;; 28
     ((48 60) (0 0)) ((16 32) (0 1))             ;;; 29
     ((48 60) (0 0)) ((16 32) (0 1))             ;;; 30
     ((48 60) (0 0)) ((16 32) (0 1))             ;;; 31
     ((24 48) (0 0)))))

(defparameter *piano-phase-patterns*
  '((64 66 71 73 74 66 64 73 71 66 74 73) ;;; 1-15   1. Teil
    ((64 66 71 73 74 66 71 73)            ;;; 16-26  2. Teil
     (64 76 69 71 74 76 69 71))
    (64 76)                               ;;; 26a    3. Teil
    (69 71 74 76)))

;;; Functions collecting events:

(defun amp-shift-collect-pno-events (pattern num-repeats start-time dtime start-shift shift pan amp)
  "Return sfz events for one Piano of one section of Piano Phase with
given params."
  (let* ((pattern-length (length pattern))
         (num-notes-no-shift (* pattern-length num-repeats))
         (num-notes-shift (+ shift num-notes-no-shift))
         (real-dtime (* dtime (/ num-notes-no-shift num-notes-shift))))
    (loop
      for i below num-notes-shift
      with (start-amp delta-amp) = (get-amp-values amp num-notes-shift)
      for curr-amp = start-amp then (+ curr-amp delta-amp)
      collect (new sfz
                :time (+ start-time (* i real-dtime))
                :keynum (elt pattern (mod (+ i start-shift) pattern-length))
                :duration dtime
                :amplitude curr-amp
                :preset :yamaha-grand-piano
                :pan pan))))

(defun amp-rest-shift-collect-section-events (patterns num-repeats start-time dtime start-shifts shifts amps)
  "Return sfz events for one section of Piano Phase with given params."
  (let ((amps (if amps amps '(nil nil))))
    (loop
      for pattern in patterns
      for start-shift in start-shifts
      for shift in shifts
      for amp in amps
      for pan from 0 by (/ 1 (1- (length shifts)))
      append (if shift (amp-shift-collect-pno-events pattern num-repeats start-time dtime start-shift shift pan amp)))))

(defun amp-rest-collect-part-events (part pattern dtime start)
  "Return all events of one part of the Piano Phase with given params."
  (let ((patterns (if (numberp (first pattern)) (list pattern pattern) pattern)))
    (loop
      for start-time = start then (+ start-time section-duration)
      for start-shifts = '(0 0) then (rest-calc-shift start-shifts shifts)
      for (num-repeats shifts amps) in part
      for section-duration = (section-duration num-repeats (first patterns) dtime)
      append (amp-rest-shift-collect-section-events patterns num-repeats start-time dtime start-shifts shifts amps))))

(defun piano-phase-amp (&optional (score (get-real-score *piano-phase-score*))
                             (patterns *piano-phase-patterns*) (tempo '(3/8 72)))
  "Return a list of all sfz instances for Piano Phase with given /score/,
/patterns/ and /tempo/."
  (loop
    with dtime = (get-duration 1/16 tempo)
    for start-time = 0 then (+ start-time part-duration)
    for part in score
    for pattern in patterns
    for expanded-pattern = (expand-pattern pattern)
    for part-duration = (part-duration part pattern dtime)
    append (amp-rest-collect-part-events part expanded-pattern dtime start-time)))
#|

;;; Example call:

(sprout
 (piano-phase-amp
  (get-real-score *piano-phase-score*)
  *piano-phase-patterns*
  '(3/8 72)))


(defparameter *my-score*   (get-real-score *piano-phase-score*))
;;; To SVG file:

(sprout
 (piano-phase-amp
  (get-real-score *piano-phase-score*)
  *piano-phase-patterns*
  '(3/8 72))
 :to (svg-gui-path "piano-phase.svg"))

;;; To Browser:

(svg->browser "piano-phase.svg")

;;; Then point your browser to http://localhost:54619/svg-display

|#