From 1dcb0e6743f27d62a2bd04b036ce784712778727 Mon Sep 17 00:00:00 2001 From: Piers Cawley Date: Sun, 16 Feb 2020 17:25:34 +0000 Subject: [PATCH 1/4] Add support for 0-argument lambdas as notes I find it handy to have a shorthand notes based on the current key/scale, but that might change over the course of a pattern, and it's also good to be able to specify accidentals that override the current scale, so simply doing `(qnt @1)` in the the note function of the looper doesn't work as well as one might hope. So... I've tweaked rmap_helper to check if `(eval l)` returns a procedure and, if so to call that proc. Thinking about this, it should be possible just do `(if (procedure @1) (@1) @1)` in the player function. However, one thing that is definitely necessary to make this work is to change `(eval l)` to `(eval (interaction-environment))`, otherwise it tries to evaluate the wrong `f` --- libs/core/pattern-language.xtm | 99 ++++++++++++++++++++++++++++++++-- 1 file changed, 94 insertions(+), 5 deletions(-) diff --git a/libs/core/pattern-language.xtm b/libs/core/pattern-language.xtm index 3bc801880..4b6a06b01 100644 --- a/libs/core/pattern-language.xtm +++ b/libs/core/pattern-language.xtm @@ -23,6 +23,15 @@ lst (append (cdr lst) '(0)))))) +(define pattern_special_atoms '(_ |)) + +(define count-specials + (lambda (lst t char) + (length (take-while (lambda (x) (equal? x char)) + (cl:nthcdr (min (cdr t) + (length lst)) + lst))))) + (define rmap_helper (lambda (beats offset func beat dur loopcnt looppos . args) (let* ((lst (rmap_helper_lst_sym_transform (if (list? (car args)) @@ -54,20 +63,25 @@ args)) (targs (map (lambda (l) (cond ((vector? l) (map (lambda (x) (eval x)) (vector->list l))) - ((and (symbol? l) (not (member l '(_ |)))) (eval l)) + ((and (symbol? l) (not (member l pattern_special_atoms))) + (let ((ll (eval l (interaction-environment)))) + (cond + ((procedure? ll) + (eval `(,ll) (interaction-environment))) + (else + ll)))) (else l))) tmpargs))) (cond ((or (list? (car tmpargs)) (pair? (car tmpargs))) (apply rmap_helper one_beat offset func (+ beat (- (car t) pos)) one_beat loopcnt (+ looppos (- (car t) pos)) targs)) - ((member (car tmpargs) '(_ |)) #f) ;; skip these symbols + ((member (car tmpargs) pattern_special_atoms) #f) ;; skip these symbols (else ;; this is a messy expression, but it just counts the number of ;; '| symbols *after* the current value, and adds them to the ;; duration - (let ((note-dur (* one_beat - (+ 1 (length (take-while (lambda (x) (equal? x '|)) - (cl:nthcdr (min (cdr t) (length (car args))) (car args)))))))) + (let ((note-dur (+ one_beat + (* one_beat (count-specials (car args) t '|))))) (apply callback (- (*metro* (+ beat (- (car t) pos))) *RMAP_HELPER_CALLBACK_OFFSET*) func (+ beat (- (car t) pos)) note-dur @@ -260,6 +274,81 @@ (list a x))) (if (list? a) a b))))) +;; Some .abc style note functions. The plain names are quantised to the +;; current *scale* by rmap_helper. Capitalised note names are in octave 3, +;; lowercase names in octave 4. In full .abc lower or higher octaves can be +;; specified by tacking , or ' respectively onto the low/high note names, but +;; I'm lazy. + +;; Quantised notes +(define (a) (qnt a4)) +(define (b) (qnt b4)) +(define (c) (qnt c4)) +(define (d) (qnt d4)) +(define (e) (qnt e4)) +(define (f) (qnt f4)) +(define (g) (qnt g4)) + +(define (A) (qnt a3)) +(define (B) (qnt b3)) +(define (C) (qnt c3)) +(define (D) (qnt d3)) +(define (E) (qnt e3)) +(define (F) (qnt f3)) +(define (G) (qnt g3)) + +;; sharpened notes; these aren't quantised +(define (^a) a#4) +(define (^b) b#4) +(define (^c) c#4) +(define (^d) d#4) +(define (^e) e#4) +(define (^f) f#4) +(define (^g) g#4) + +(define (^A) a#3) +(define (^B) b#3) +(define (^C) c#3) +(define (^D) d#3) +(define (^E) e#3) +(define (^F) f#3) +(define (^G) g#3) + +;; flattened notes. Not quantised +(define (_a) ab4) +(define (_b) bb4) +(define (_c) cb4) +(define (_d) db4) +(define (_e) eb4) +(define (_f) fb4) +(define (_g) gb4) + +(define (_A) ab3) +(define (_B) bb3) +(define (_C) cb3) +(define (_D) db3) +(define (_E) eb3) +(define (_F) fb3) +(define (_G) gb3) + +;; Naturals, again not quantised +(define (=a) a3) +(define (=b) b3) +(define (=c) c3) +(define (=d) d3) +(define (=e) e3) +(define (=f) f3) +(define (=g) g3) + +(define (=A) a4) +(define (=B) b4) +(define (=C) c4) +(define (=D) d4) +(define (=E) e4) +(define (=F) f4) +(define (=G) g4) + + ;; euclidean rhythms ;; written by Ben in recursive Scheme; Kernighan's aphorism probably applies From 91611079d8971435951c0016c3b55cd4526dafb4 Mon Sep 17 00:00:00 2001 From: Piers Cawley Date: Fri, 21 Feb 2020 18:47:09 +0000 Subject: [PATCH 2/4] Extend the pattern language to allow for dotted and shortened notes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A common pattern in traditional tunes is the 𝅘𝅥𝅭 𝅘𝅥𝅮 rhythm, which proved to be annoyingly hard to express in the ':>' pattern language. You basically have to replace every note with 'note |', and then do 'dotted-crotchet | | quaver' which is somewhat annoying. So, I extended the language to make `note + note -` do the trick (it too me a while to spot that scheme was never going to let me do `note . note -`. I've also factored out the code that maps from a note symbol to a number and which works out where the actual notes are in a pattern and calculates their positions (both in time and within the pattern list). In theory, this should allow for the pattern interpretation part of the pattern player to be parameterised, but I've not really started on that work yet. --- libs/core/pattern-language.xtm | 158 ++++++++++++++++++++++++++------- 1 file changed, 124 insertions(+), 34 deletions(-) diff --git a/libs/core/pattern-language.xtm b/libs/core/pattern-language.xtm index 4b6a06b01..7ba4d5e50 100644 --- a/libs/core/pattern-language.xtm +++ b/libs/core/pattern-language.xtm @@ -23,15 +23,115 @@ lst (append (cdr lst) '(0)))))) -(define pattern_special_atoms '(_ |)) +(define pattern_atom_duration + (lambda (atm) + (cond ((eq? '| atm) 1) + ((eq? '+ atm) 1/2) + ((eq? '- atm) -1/2) + (else 1)))) + +(define rmap_pattern_length + (lambda (lst) + (apply + (map pattern_atom_duration lst)))) + +(define (modify_duration_by dur lst) + (let ((modifiers (take-while is_modifier? lst))) + (foldl (lambda (d m) + (cond ((eq? '| m) (+ d dur)) + ((eq? '+ m) (* 3/2 d)) + ((eq? '- m) (* 1/2 d)))) + dur modifiers))) + +(define skip_leading_modifiers + (lambda (lists) + (map (lambda (l) (drop-while is_modifier? l)) + lists))) + + +(define pattern_special_atoms '(_ | + -)) +(define pattern_modifiers '(+ - |)) + + +(define is_special? + (lambda (atom) (member atom pattern_special_atoms))) + +(define is_modifier? + (lambda (atom) (member atom pattern_modifiers))) + +(define count_specials + (lambda (lst t char) + (length (take-while (lambda (x) (equal? x char)) + (cl:nthcdr (min (cdr t) + (length lst)) + lst))))) -(define count-specials +(define event_locations + (lambda (base-duration lst) + (let loop ((res '()) + (l lst) + (list-pos 1) + (total-dur 0)) + (if (null? l) (reverse res) + (let* ((evt (car l)) + (modifiers (take-while is_modifier? (cdr l))) + (next-l-pos (+ 1 (length modifiers))) + (elapsed (+ total-dur (modify_duration_by base-duration modifiers)))) + (loop (cons (cons total-dur list-pos) res) + (cl:nthcdr next-l-pos l) + (+ list-pos next-l-pos) + elapsed)))))) + +(define count_specials (lambda (lst t char) (length (take-while (lambda (x) (equal? x char)) (cl:nthcdr (min (cdr t) (length lst)) lst))))) + +(define evaluate_event + (lambda (evt) + (cond ((vector? evt) (map (lambda (x) (eval x (interaction-environment))) + (vector->list l))) + ((and (symbol? evt) (not (is_special? evt))) + (let ((ll (eval evt (interaction-environment)))) + (if (procedure? ll) + (eval `(,ll) (interaction-environment)) + (else ll)))) + evt))) + + +(define make_tmpargs + (lambda (t args) + (map (lambda (l) + (if (list? l) + (set! l (rmap_helper_lst_sym_transform l)) + (if (pair? l) + (set! l ((eval (cdr l)) (rmap_helper_lst_sym_transform (car l)))) + (set! l (list l)))) + (if (< (length l) (cdr t)) + (list-ref l (modulo (- (cdr t) 1) (length l))) + (list-ref l (- (cdr t) 1)))) + args))) + +(define make_targs + (lambda (tmpargs) + (reverse + (foldl (lambda (acc l) + (cond + ((vector? l) (cons (map (lambda (x) (eval x)) (vector->list l)) acc)) + ((and (symbol? l) (not (is_special? l))) + (let ((ll (eval l (interaction-environment)))) + (cons (cond + ((procedure? ll) + (eval `(,ll) (interaction-environment))) + (else + ll)) + acc))) + (else (cons l acc)))) + '() tmpargs)))) + + (define rmap_helper (lambda (beats offset func beat dur loopcnt looppos . args) (let* ((lst (rmap_helper_lst_sym_transform (if (list? (car args)) @@ -40,38 +140,19 @@ (caar args) '(_ _ _ _))))) (pos (modulo (- looppos offset) beats)) ;;(modulo (- beat offset) beats)) - (one_beat (/ beats (length lst))) - (lst_positions (range 0 (+ pos beats) one_beat)) + (one_beat (/ beats (rmap_pattern_length lst))) (nextpos (+ pos dur)) - (idx 0) (f (lambda (old new) - (set! idx (+ idx 1)) - (if (and (>= new pos) (< new nextpos)) - (cons (cons new idx) old) - old))) - (newlst (foldl f '() lst_positions))) + (let ((newpos (car new)) + (idx (cdr new))) + (if (and (>= newpos pos) (< newpos nextpos)) + (cons new old) + old)))) + (newlst (foldl f '() (event_locations one_beat lst))) + ) (map (lambda (t) - (let* ((tmpargs (map (lambda (l) - (if (list? l) - (set! l (rmap_helper_lst_sym_transform l)) - (if (pair? l) - (set! l ((eval (cdr l)) (rmap_helper_lst_sym_transform (car l)))) - (set! l (list l)))) - (if (< (length l) (cdr t)) - (list-ref l (modulo (- (cdr t) 1) (length l))) - (list-ref l (- (cdr t) 1)))) - args)) - (targs (map (lambda (l) - (cond ((vector? l) (map (lambda (x) (eval x)) (vector->list l))) - ((and (symbol? l) (not (member l pattern_special_atoms))) - (let ((ll (eval l (interaction-environment)))) - (cond - ((procedure? ll) - (eval `(,ll) (interaction-environment))) - (else - ll)))) - (else l))) - tmpargs))) + (let* ((tmpargs (make_tmpargs t args)) + (targs (make_targs tmpargs))) (cond ((or (list? (car tmpargs)) (pair? (car tmpargs))) (apply rmap_helper one_beat offset func (+ beat (- (car t) pos)) one_beat loopcnt (+ looppos (- (car t) pos)) targs)) @@ -80,10 +161,10 @@ ;; this is a messy expression, but it just counts the number of ;; '| symbols *after* the current value, and adds them to the ;; duration - (let ((note-dur (+ one_beat - (* one_beat (count-specials (car args) t '|))))) + (let ((note-dur (modify_duration_by one_beat (cl:nthcdr (min (cdr t) (length lst)) + lst)))) (apply callback - (- (*metro* (+ beat (- (car t) pos))) *RMAP_HELPER_CALLBACK_OFFSET*) + (- (*metro* (+ beat (- (car t) pos))) (* 2 *RMAP_HELPER_CALLBACK_OFFSET*)) func (+ beat (- (car t) pos)) note-dur loopcnt targs)))))) newlst)))) @@ -128,6 +209,7 @@ (println name))) (begin (eval `(define ,name (lambda (beat totaldur loopcnt dur) + (println `(f ,beat ,totaldur ,loopcnt ,dur)) (define beats ,beatsexpr) (define offset ,offsetexpr) (define LC loopcnt) @@ -409,6 +491,14 @@ ((pred (car remaining)) (loop (cons (car remaining) ret) (cdr remaining))) (else (reverse ret)))))) +(define drop-while + (lambda (pred lst) + (let loop ((ret lst)) + (cond ((null? ret)) + ((pred (car ret)) (loop (cdr ret))) + (else ret))))) + + ;; skip by m with a lst rotation of r ;; for example: (skip 2 -1 (scale 3 8)) (define skip From ce61f0f4fff5a41b375dd3953ab9bd3d3e97e7c3 Mon Sep 17 00:00:00 2001 From: Piers Cawley Date: Sat, 22 Feb 2020 08:34:19 +0000 Subject: [PATCH 3/4] Remove a stray debugging `println` --- libs/core/pattern-language.xtm | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/core/pattern-language.xtm b/libs/core/pattern-language.xtm index 7ba4d5e50..f245fcb98 100644 --- a/libs/core/pattern-language.xtm +++ b/libs/core/pattern-language.xtm @@ -209,7 +209,6 @@ (println name))) (begin (eval `(define ,name (lambda (beat totaldur loopcnt dur) - (println `(f ,beat ,totaldur ,loopcnt ,dur)) (define beats ,beatsexpr) (define offset ,offsetexpr) (define LC loopcnt) From f22316404d0f643d816cec47fa8e029a0e112824 Mon Sep 17 00:00:00 2001 From: Piers Cawley Date: Sat, 22 Feb 2020 11:36:36 +0000 Subject: [PATCH 4/4] Make | work compound notes This lets us express the common 3 notes in the space of 2 triplet by doing something like: (60 62 63) | --- libs/core/pattern-language.xtm | 47 +++++++++++++++++----------------- 1 file changed, 23 insertions(+), 24 deletions(-) diff --git a/libs/core/pattern-language.xtm b/libs/core/pattern-language.xtm index f245fcb98..73455f830 100644 --- a/libs/core/pattern-language.xtm +++ b/libs/core/pattern-language.xtm @@ -75,8 +75,9 @@ (let* ((evt (car l)) (modifiers (take-while is_modifier? (cdr l))) (next-l-pos (+ 1 (length modifiers))) - (elapsed (+ total-dur (modify_duration_by base-duration modifiers)))) - (loop (cons (cons total-dur list-pos) res) + (duration (modify_duration_by base-duration modifiers)) + (elapsed (+ total-dur duration))) + (loop (cons (cons total-dur (cons duration list-pos)) res) (cl:nthcdr next-l-pos l) (+ list-pos next-l-pos) elapsed)))))) @@ -109,9 +110,9 @@ (if (pair? l) (set! l ((eval (cdr l)) (rmap_helper_lst_sym_transform (car l)))) (set! l (list l)))) - (if (< (length l) (cdr t)) - (list-ref l (modulo (- (cdr t) 1) (length l))) - (list-ref l (- (cdr t) 1)))) + (if (< (length l) (cddr t)) + (list-ref l (modulo (- (cddr t) 1) (length l))) + (list-ref l (- (cddr t) 1)))) args))) (define make_targs @@ -131,6 +132,12 @@ (else (cons l acc)))) '() tmpargs)))) +(define is_position_between? + (lambda (startpos endpos) + (lambda (pos-cell) + (let ((pos (car pos-cell))) + (and (>= pos startpos) + (< pos endpos)))))) (define rmap_helper (lambda (beats offset func beat dur loopcnt looppos . args) @@ -142,31 +149,23 @@ (pos (modulo (- looppos offset) beats)) ;;(modulo (- beat offset) beats)) (one_beat (/ beats (rmap_pattern_length lst))) (nextpos (+ pos dur)) - (f (lambda (old new) - (let ((newpos (car new)) - (idx (cdr new))) - (if (and (>= newpos pos) (< newpos nextpos)) - (cons new old) - old)))) - (newlst (foldl f '() (event_locations one_beat lst))) - ) + (newlst (filter (is_position_between? pos nextpos) + (event_locations one_beat lst)))) + (map (lambda (t) (let* ((tmpargs (make_tmpargs t args)) - (targs (make_targs tmpargs))) + (targs (make_targs tmpargs)) + (current-dur (cadr t)) + ) (cond ((or (list? (car tmpargs)) (pair? (car tmpargs))) - (apply rmap_helper one_beat offset func (+ beat (- (car t) pos)) one_beat loopcnt (+ looppos (- (car t) pos)) targs)) + (apply rmap_helper current-dur offset func (+ beat (- (car t) pos)) current-dur loopcnt (+ looppos (- (car t) pos)) targs)) ((member (car tmpargs) pattern_special_atoms) #f) ;; skip these symbols (else - ;; this is a messy expression, but it just counts the number of - ;; '| symbols *after* the current value, and adds them to the - ;; duration - (let ((note-dur (modify_duration_by one_beat (cl:nthcdr (min (cdr t) (length lst)) - lst)))) - (apply callback - (- (*metro* (+ beat (- (car t) pos))) (* 2 *RMAP_HELPER_CALLBACK_OFFSET*)) - func (+ beat (- (car t) pos)) note-dur - loopcnt targs)))))) + (apply callback + (- (*metro* (+ beat (- (car t) pos))) *RMAP_HELPER_CALLBACK_OFFSET*) + func (+ beat (- (car t) pos)) current-dur + loopcnt targs))))) newlst)))) ;; rhythm map